(17.03.2017, 22:34)elgato2000 schrieb: Danke für den hinweis Tom, ich habe irrtümlicherweise "echte Daten" angehängt. Moderator möchte die Anhänge bitte löschen
Wenn Du genau hingeschaut hast, lag das Problem tiefer und nicht nur in leeren Zellen.
Sub mach_mal()
Dim i As Long, j As Long, jj As Long
Dim lngZ As Long
lngZ = Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To lngZ - 1
If Cells(i, 2) = "" Then
Do
j = j + 1
Loop Until Cells(i + j, 2) <> "" And j <= lngZ
For jj = 1 To j - 1
Cells(i + jj - 1, 2) = Cells(i - 1, 2) & " " & jj + 1
Cells(i + jj - 1, 4) = Cells(i - 1, 4).Value
Range(Cells(i - 1, 6), Cells(i + jj - 1, 6)) = Range(Cells(i, 6), Cells(i + jj, 6)).Value
Next jj
End If
j = 0
Next i
Range("B2:B" & lngZ).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For i = 2 To lngZ
jj = Application.CountIf(Range("B2:B" & i), Cells(i, 2))
If jj > 1 Then
Cells(i, 2) = Cells(i - 1, 2) & " " & jj
End If
Next i
End Sub
Sub mach_mal()
Dim i As Long, j As Long, jj As Long
Dim lngZ As Long
lngZ = Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To lngZ - 1
If Cells(i, 2) = "" Then
Do
j = j + 1
Loop Until Cells(i + j, 2) <> "" And j <= lngZ
For jj = 1 To j - 1
Cells(i + jj - 1, 2) = Cells(i - 1, 2) & " " & jj + 1
Cells(i + jj - 1, 4) = Cells(i - 1, 4).Value
Next jj
Range(Cells(i - 1, 6), Cells(i + jj - 2, 6)) = Range(Cells(i, 6), Cells(i + jj - 1, 6)).Value
End If
j = 0
Next i
Range("B2:B" & lngZ).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
For i = 2 To lngZ
jj = Application.CountIf(Range("B2:B" & i), Cells(i, 2))
If jj > 1 Then
Cells(i, 2) = Cells(i - 1, 2) & " " & jj
End If
Next i
End Sub