Excel: Maßnahmen zählen und Graphik erstellen

Option Explicit
'Im WS Maßnahmen werden Maßnahmen festgehalten.
'Ich möchte festhalten wieviele Maßnahmen haben wir
' - aktuell
' - Anzahl überschrittener Maßnahmen
' - Anzahl aktuelle Maßnahmen.
'
'Die Termine stehen ab der Zelle B5.
' - Abgelaufen            -> rot
' - InDenNaechstenTagen   -> gelb
' - Zukunft               -> weiß.
'

'OFFEN
'Die Auswertung soll enthalten:
' - Datum  der Auswertung,
' - Anzahl offener Maßnahmen,
' - Anzahl überschrittener Maßnahmen
' - Anzahl der Maßnahmen, die in den nächsten Tagen anfallen
' - Anzahl aktuelle Maßnahmen.
'
'Ich möchte die Auswertung per Knopfdruck ausführen.
'Nach der Auswertung soll noch eine Liniengraphik erstellt werden.
'OFFEN ENDE

Sub Excel_FALCON_MassnahmenZaehlenUndGraphikErstellen()

  Const lFarbe_Abgelaufen = 3         ->knallrot
  Const lFarbe_InDenNaechstenTagen = 6->knallgelb
  Const lFarbe_Zukunft = 2             'weiß
  
  Dim lAnzAbgelaufen As Long
  Dim lAnzInDenNaechstenTagen As Long
  Dim lAnzZukunft As Long
  Dim lAnzAndere As Long
  Dim sDatumDerAuswertung As String, dDate As Date
  
  dDate = Now()
  sDatumDerAuswertung = _
    Year(dDate) & Format(Month(dDate), 00) & Format(Day(dDate), 00)
  
  If Not MassnahmenAuszaehlen( _
           Maßnahmen, B5, _
           lFarbe_Abgelaufen, lFarbe_InDenNaechstenTagen, lFarbe_Zukunft, _
           lAnzAbgelaufen, lAnzInDenNaechstenTagen, lAnzZukunft, lAnzAndere) Then
    Exit Sub
  End If

  MsgBox _
    Resultat->MassnahmenAuszaehlen' vom  & sDatumDerAuswertung & : & vbLf & _
    Format(lAnzAbgelaufen, ###0) &  - Anz. abgelaufen & vbLf & _
    Format(lAnzInDenNaechstenTagen, ###0) &  - Anz. in den nächsten Tagen & vbLf & _
    Format(lAnzZukunft, ###0) &  - Anz. zukünftige & vbLf & _
    Format(lAnzAndere, ###0) &  - Anz. andere
    
End Sub

'************************************************************************
Function MassnahmenAuszaehlen( _
            sBltname As String, _
            sRange As String, _
            lFarbe_Abgelaufen As Long, _
            lFarbe_InDenNaechstenTagen As Long, _
            lFarbe_Zukunft As Long, _
            lAnzAbgelaufen As Long, _
            lAnzInDenNaechstenTagen As Long, _
            lAnzZukunft As Long, _
            lAnzAndere As Long) As Boolean
        
  Dim ws As Worksheet, r As Range
  Dim lFarbe As Long, lZeilenOffset As Long
  
  On Error Resume Next
  Set ws = ActiveWorkbook.Worksheets(sBltname)
  On Error GoTo 0
  If ws Is Nothing Then
    MsgBox Blatt-> & sBltname &-> ist nicht erreichbar.
    GoTo AUFRAEUMEN
  End If
  
  On Error Resume Next
  Set r = ws.Range(sRange)
  On Error GoTo 0
  If r Is Nothing Then
    MsgBox Rangeangabe-> & sRange &-> ist nicht zulässig.
    GoTo AUFRAEUMEN
  ElseIf r.Count > 1 Then
    MsgBox Rangeangabe-> & sRange &-> ist nicht zulässig.
    GoTo AUFRAEUMEN
  End If
  
  lAnzAbgelaufen = 0
  lAnzInDenNaechstenTagen = 0
  lAnzZukunft = 0
  lAnzAndere = 0
  
  lZeilenOffset = 0
  
  Do
    If r.Offset(lZeilenOffset, 0).Value =  Then Exit Do
    
    lFarbe = r.Offset(lZeilenOffset, 0).Font.ColorIndex
    If lFarbe = lFarbe_Abgelaufen Then
      lAnzAbgelaufen = lAnzAbgelaufen + 1
    ElseIf lFarbe = lFarbe_InDenNaechstenTagen Then
      lAnzInDenNaechstenTagen = lAnzInDenNaechstenTagen + 1
    ElseIf lFarbe = lFarbe_Zukunft Then
      lAnzZukunft = lAnzZukunft + 1
    Else
      lAnzAndere = lAnzAndere + 1
    End If
    
    lZeilenOffset = lZeilenOffset + 1
  Loop
  
  MassnahmenAuszaehlen = True
AUFRAEUMEN:
  Set ws = Nothing: Set r = Nothing
End Function