|
|
Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:h" & r)
End With
s = 0
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 4)) Then
Set d(arr(i, 4)) = CreateObject("scripting.dictionary")
End If
If Not d(arr(i, 4)).exists(arr(i, 2)) Then
ReDim brr(1 To 4)
brr(1) = arr(i, 4)
brr(2) = arr(i, 2)
s = s + 1
Else
brr = d(arr(i, 4))(arr(i, 2))
End If
brr(3) = brr(3) + arr(i, 7)
brr(4) = brr(4) + arr(i, 8)
d(arr(i, 4))(arr(i, 2)) = brr
Next
ReDim crr(1 To s, 1 To 4)
m = 0
For Each aa In d.keys
For Each bb In d(aa).keys
brr = d(aa)(bb)
m = m + 1
For j = 1 To UBound(brr)
crr(m, j) = brr(j)
Next
Next
Next
With Worksheets("sheet1")
.Range("l2").Resize(UBound(crr), UBound(crr, 2)) = crr
End With
End Sub |
|
