[flinx]

Update:Es passt! THX²!

Fein.
Wennst nur die einfachen eliminiert haben willst und die doppelten erhalten:

Sub multiple2()
 'Create Temp
 ActiveSheet.Columns("A:A").Select
 Selection.Copy
 ActiveSheet.Range("E1").Select
 ActiveSheet.Paste
 
 i = 2
 h = 2
 
Application.ScreenUpdating = False
While (ActiveSheet.Cells(i, 5).Value <> "")
   Count = 1
   j = i + 1
   While (ActiveSheet.Cells(j, 5).Value <> "")
      If ActiveSheet.Cells(i, 5).Value = ActiveSheet.Cells(j, 5).Value Then
        If Count = 1 Then ActiveSheet.Cells(h, 6).Value = ActiveSheet.Cells(i, 5).Value
        Count = Count + 1
        h = h + 1
        ActiveSheet.Cells(h, 6).Value = ActiveSheet.Cells(j, 5).Value
        ActiveSheet.Cells(j, 5).Delete Shift:=xlUp
      Else
        j = j + 1
      End If
     
   Wend
   If Count > 1 Then
       ActiveSheet.Cells(h, 7).Value = Count
       i = i + 1
       h = h + 1
   Else
   ActiveSheet.Cells(i, 5).Delete Shift:=xlUp
   End If
Wend
Application.ScreenUpdating = True
End Sub