Sub Mustermann()
Dim arr(), x, v, w
arr = ActiveSheet.UsedRange.Columns(1).Resize(, 2).Value
ReDim Preserve arr(1 To UBound(arr, 1), 1 To UBound(arr, 2) + 1)
For x = 1 To UBound(arr, 1)
arr(x, 3) = arr(x, 1) & arr(x, 2)
Next x
v = arr(UBound(arr, 1), 3)
For x = UBound(arr, 1) To 2 Step -1
If arr(x - 1, 3) <> v Then
v = arr(x - 1, 3)
Rows(x).Insert
With Rows(x)
With Range(.Cells(1), .Cells(3))
.Interior.Color = vbGreen
.Font.Bold = True
End With
.Cells(1).Value = arr(x - 1, 1)
.Cells(2).Value = arr(x - 1, 2)
End With
End If
Next x
arr = ActiveSheet.UsedRange.Columns(3).Value
For x = 1 To UBound(arr, 1) - 1
If arr(x, 1) <> "" Then
w = w + arr(x, 1)
Else
arr(x, 1) = w
w = 0
End If
Next x
ActiveSheet.UsedRange.Columns(3).Value = arr
End Sub