Sub AuchLösungsvorschlag()
Dim rngU As Range, rngH As Range
Dim x As Long, Flag As Boolean
Application.ScreenUpdating = False
Set rngU = Range(Cells(1), Cells(Cells.Find("*", _
Cells(1), -4123, 2, 1, 2, False).Row, _
Cells.Find("*", Cells(1), -4123, 2, 2, 2, False).Column))
Set rngH = rngU.Columns(1).Offset(, rngU.Columns.Count)
For x = 1 To rngU.Rows.Count
If WorksheetFunction.SumIf(rngU.Columns(2), Cells(x, 2), rngH) = 0 Then
rngH.Cells(x) = WorksheetFunction.SumIf( _
rngU.Columns(2), Cells(x, 2), rngU.Columns(1))
Else
rngH.Cells(x) = 0
End If
Next x
Flag = True
For x = rngH.Cells.Count To 1 Step -1
If Flag And x = 1 Then Exit For
If rngH.Cells(x) > 0 Then
Cells(x, 1) = rngH.Cells(x)
Else
rngH.Cells(x).EntireRow.Delete
End If
Next x
rngU.Columns(1).Offset(, rngU.Columns.Count).Clear
Application.ScreenUpdating = True
End Sub