Sub DoIt()
Dim arrDict() As Variant, x As Long, v, arrItems, arrKeys, arr() As String
Dim objDict As Scripting.Dictionary
Set objDict = New Scripting.Dictionary
arrDict = Cells(1).CurrentRegion.Value
With objDict
For x = LBound(arrDict, 1) To UBound(arrDict, 1)
v = arrDict(x, 1) & ";" & arrDict(x, 2)
On Error Resume Next
.Add v, arrDict(x, 3)
If Err.Number Then .Item(v) = .Item(v) + arrDict(x, 3)
On Error GoTo 0
Next x
arrItems = .Items
arrKeys = .Keys
End With
ReDim arrDict(1 To UBound(arrKeys) + 1, 1 To 3)
For x = LBound(arrKeys) To UBound(arrKeys)
arr = Split(arrKeys(x), ";")
arrDict(x + 1, 1) = arr(0)
arrDict(x + 1, 2) = arr(1)
arrDict(x + 1, 3) = arrItems(x)
Next x
Cells(4).Resize(UBound(arrDict, 1), UBound(arrDict, 2)).Value = arrDict
Call MsgBox(WorksheetFunction.Sum(Columns(3)) & " zu " & WorksheetFunction.Sum(Columns(6)), vbInformation, "Kontrolle")
Set objDict = Nothing
End Sub