|
Hallo Sabine
so?
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) 'Anfangszeile
e = i 'Endzeile
If Len(.Cells(i + 1, 1)) = 4 Then 'ist nächster Wert auch 4 stellig
e = i + 1 'Neue Endzeile
Else 'letzte Zeile gefunden
Set RNG = .Range(.Cells(a, 1), .Cells(e, 1)) 'Bereich Anfang bis Ende
'Texte mit "Komma" verbinden und in Zelle schreiben
.Cells(i, 1).Offset(0, 1) = Join(WorksheetFunction.Transpose(RNG), ", ")
a = 0
End If
End If
Next
End With
End Sub
LG UweD
|