Sub zusammen2()
Dim z, zaehler, zeile, lzeile As Long
Dim feld()
Dim neu As Boolean
'letzte Zeile in Spalte AA ermitteln
lzeile = ActiveSheet.Cells(Rows.Count, 27).End(xlUp).Row
'Feld neu dimensionieren
ReDim feld(lzeile - 1, 4)
'Schalter für Prüfung auf wahr setzen
neu = True
'Zeilen und Inhalte der Spalten in Array einlesen
For zeile = 2 To lzeile
'Prüfen, ob Inhalt der Spalte Y schon im Array vorhanden ist
For z = 0 To zaehler
If feld(z, 1) = Cells(zeile, 27) Then neu = False
Next z
'falls nein, dann Daten in Array aufnehmen
If neu = True Then
zaehler = zaehler + 1
feld(zaehler, 0) = zeile
feld(zaehler, 1) = Cells(zeile, 27) 'Spalte AA
feld(zaehler, 2) = Cells(zeile, 29) 'Spalte AC
feld(zaehler, 3) = Cells(zeile, 17) 'Spalte Q
feld(zaehler, 4) = Cells(zeile, 9) 'Spalte I
Else
neu = True 'Schalter wieder auf wahr setzen, falls ein Element schon vorhanden war
End If
Next zeile
'Vergleichen und ggf. Inhalte zusammensetzen
For zeile = 2 To lzeile
For z = 1 To zaehler
If Cells(zeile, 27) = feld(z, 1) And zeile > feld(z, 0) Then
feld(z, 2) = feld(z, 2) & Chr(10) & Cells(zeile, 29)
feld(z, 3) = feld(z, 3) & Chr(10) & Cells(zeile, 17)
feld(z, 4) = feld(z, 4) & Chr(10) & Cells(zeile, 9)
End If
Next z
Next zeile
'Spalten W bis Y löschen
Range(Cells(2, 23), Cells(lzeile, 25)).ClearContents
'zusammengesetzten Inhalt in Spalten schreiben
For z = 1 To zaehler
Cells(feld(z, 0), 25) = feld(z, 2) 'AC in Y
Cells(feld(z, 0), 24) = feld(z, 3) 'Q in X
Cells(feld(z, 0), 23) = feld(z, 4) 'I in W
Next z
End Sub
M.O.