Sub NachVorlage()
Dim Ws As Worksheet
Dim rngU As Range, rngG As Range, rngA As Range, rngC As Range
Dim Chain As String, Flag As Boolean
Set Ws = ActiveSheet
With Ws
Set rngU = .UsedRange.Columns(7)
Set rngG = rngU.SpecialCells(xlCellTypeBlanks)
For Each rngA In rngG.Areas
Chain = "": Flag = False
For Each rngC In rngA.Cells
If rngC.Offset(, -6) = rngA.Cells(1).Offset(-1, -6) Then
Chain = Chain & ", " & rngC.Offset(, -5) & " " & rngC.Offset(, -4)
Flag = True
End If
Next rngC
If Flag Then rngA.Cells(1).Offset(-1, 5) = Mid(Chain, 3)
Next rngA
End With
End Sub