zählen und merken

Sub test()
Application.ScreenUpdating = False
Dim i As Long, oDict As Object, strKey As String
Set oDict = CreateObject("scripting.dictionary")
Sheets("Liste1").Select
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
strKey = Cells(i, 4) & "-" & Cells(i, 5)
oDict(strKey) = oDict(strKey) + 1
Next
Sheets("Liste2").Select
With Cells(2, 3).Resize(oDict.Count)
.NumberFormat = "@"
.Value = WorksheetFunction.Transpose(oDict.keys)
End With
Cells(2, 11).Resize(oDict.Count) = WorksheetFunction.Transpose(oDict.items)
End Sub