[flinx]

Ohne Gewähr:

Sub multiple()
 ActiveSheet.Columns("A:A").Select
 Selection.Copy
 ActiveSheet.Range("B1").Select
 ActiveSheet.Paste
 
 i = 2
 h = 2
 
Application.ScreenUpdating = False
While (ActiveSheet.Cells(i, 2).Value <> "")
   Count = 1
   j = i + 1
   While (ActiveSheet.Cells(j, 2).Value <> "")
      If ActiveSheet.Cells(i, 2).Value = ActiveSheet.Cells(j, 2).Value Then
        Count = Count + 1
        ActiveSheet.Cells(j, 2).Delete Shift:=xlUp
      Else
        j = j + 1
      End If     
   Wend
   If Count > 1 Then
       ActiveSheet.Cells(h, 3).Value = Count
       h = h + 1
       i = i + 1
   Else
   ActiveSheet.Cells(i, 2).Delete Shift:=xlUp
   End If
Wend
Application.ScreenUpdating = True
End Sub

S.a. Attachment