Hi,
versuche es mal mit folgendem Code (Achtung, vorher Kope der Originaldaten anlegen!!):
Sub Zusammenfassen()
Dim lngZeile As Long
Dim lngStart As Long
Application.DisplayAlerts = False
For lngZeile = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) To 2 Step -1
lngStart = lngZeile
If Application.CountIf(Columns(2), Cells(lngZeile, 2)) > 1 Then
Do
Cells(lngStart - 1, 1) = Cells(lngStart - 1, 1) & ", " & Cells(lngStart, 1)
Rows(lngStart).Delete
lngStart = lngStart - 1
If lngStart = 1 Then Exit Do
If Cells(lngStart - 1, 2) <> Cells(lngStart, 2) Then Exit Do
Loop
lngZeile = lngStart
End If
Next lngZeile
Application.DisplayAlerts = False
End Sub
Bis später,
Karin