Option Explicit
Sub StatistikDatum()
'die selektierten(markierten) Zellen werden nach Datumsangaben durchsucht.
'Auf einem angefügten Blatt wird
'jedes erkannte Datum und seine Häufigkeit ausgegeben
Const c_BlattName As String = Statistik_Datum
Dim Zelle As Range
Dim ws As Worksheet, ws_a As Worksheet
Dim l_row As Long, l_ColCount As Long
Dim b_gefunden As Boolean
'*** aktives Blatt merken
Set ws_a = ActiveSheet
'*** altes Blatt Statistik_Datum löschen, wenn vorhanden
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets(c_BlattName).Delete
Application.DisplayAlerts = True
'*** neues Ergebnisblatt an Ende anfügen
ActiveWorkbook.Worksheets.Add After:=ActiveWorkbook. _
Worksheets(ActiveWorkbook.Worksheets.Count)
Set ws = ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)
'*** Beschriftung
ws.Name = c_BlattName
ws.Cells(1, 1) = Datum: ws.Cells(1, 1).Font.Bold = True
ws.Cells(1, 2) = Häufigkeit: ws.Cells(1, 2).Font.Bold = True
l_ColCount = 1
'*** alle markierten zellen auswerten
ws_a.Activate
For Each Zelle In Selection
If IsDate(Zelle) Then
b_gefunden = False
For l_row = 2 To l_ColCount
If Zelle.Value = ws.Cells(l_row, 1).Value Then
'Datum gefunden -> Abbruch der Suchschleife
b_gefunden = True: Exit For
End If
Next l_row
If b_gefunden Then 'Datum bereits vorhanden -> Häufigkeit+1
ws.Cells(l_row, 2).Value = ws.Cells(l_row, 2).Value + 1
Else 'Datum noch nicht vorhanden -> Datum eintragen, Häufigkeit=1
ws.Cells(l_row, 1).Value = Zelle.Value
ws.Cells(l_row, 2).Value = 1
l_ColCount = l_ColCount + 1
End If
End If
Next
ws.Columns(1).AutoFit
ws.Columns(2).AutoFit
End Sub
