Sub Kette()
Dim lngLastRow As Long, RNG As Range
Dim Neu As String, a As Long, e As Long, i As Long
With Worksheets("Tabelle1")
lngLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 6 To lngLastRow
If Len(.Cells(i, 1)) = 4 Then
a = IIf(a = 0, i, a)
e = i
If Len(.Cells(i + 1, 1)) = 4 Then
e = i + 1
Else
Set RNG = .Range(.Cells(a, 1), .Cells(e, 1))
.Cells(i, 1).Offset(0, 1) = Join(WorksheetFunction.Transpose(RNG), ", ")
a = 0
End If
End If
Next
End With
End Sub