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