Hallo,

habe den VBA Code folgendermaßen angepasst. Könnte man eigentlich via VBA noch ein Kuchendiagramm erzeugen?

Option Explicit
 
 
Sub Auswertung()
 
 
Application.ScreenUpdating = False
 
 
      Dim p As Integer
      Dim st As Integer
      Dim s As Integer
      Dim e As Integer
      Dim w As Integer
      Dim Start As Date
      Dim Ende As Date
       
       
    Dim arr, i, j, v(3), a(3)
     
    arr = Array("Abgeschlossen", "Laufend", "Angebot", "Abgelehnt")
     
    p = 4 'Erste Zeilenummer der Werte
    st = 1 'Spaltennummer Status
    s = 9 'Spaltennummer Projektstart
    e = 11 'Spaltennummer Projektende
    w = 3 'Spaltennummer Personentage
     
     
    ThisWorkbook.Worksheets("Industrie").Activate
     
    With Worksheets("Industrie Auswertung")
     
     
        Start = .Range("C5").Value
         
        Ende = .Range("D5").Value
         
         
        For j = 0 To 3
         
            For i = p To Cells(Rows.Count, st).End(xlUp).Row
             
                If Cells(i, s) >= Start And Cells(i, e) <= Ende And Cells(i, st) = arr(j) Then
                 
                    v(j) = v(j) + Cells(i, w).Value
                     
                    a(j) = a(j) + 1
                     
                End If
                 
            Next i
             
        Next j
         
         
        Worksheets("Industrie Auswertung").Range("E5").Value = "Beauftragt"
 
        Worksheets("Industrie Auswertung").Range("E6").Value = "Unklar"
 
        Worksheets("Industrie Auswertung").Range("E7").Value = "Abgelehnt"
         
        Worksheets("Industrie Auswertung").Range("F5").Value = a(0) + a(1)
 
        Worksheets("Industrie Auswertung").Range("F6").Value = a(2)
 
        Worksheets("Industrie Auswertung").Range("F7").Value = a(3)
 
        Worksheets("Industrie Auswertung").Range("G5").Value = v(0) + v(1)
 
        Worksheets("Industrie Auswertung").Range("G6").Value = v(2)
 
        Worksheets("Industrie Auswertung").Range("G7").Value = v(3)
         
         
        .Activate
         
         
        .Cells(1, 1).Select
         
         
        Application.ScreenUpdating = True
         
         
    End With
     
     
End Sub
 

Danke und viele Grüße