Sub test()
Dim dc1, dc2, arr, brr, aa, bb, ys, ddh, str, i, m
Set dc1 = CreateObject("Scripting.Dictionary")
Set dc2 = CreateObject("Scripting.Dictionary")
arr = Sheet1.[A2].CurrentRegion
For i = 3 To UBound(arr)
aa = arr(i, 1)
bb = arr(i, 2)
If Not dc1.Exists(aa) Then
Set dc1(aa) = CreateObject("Scripting.Dictionary")
End If
dc1(aa)(bb) = i
Next
brr = Sheet2.[A1].CurrentRegion
m = 0
For i = 3 To UBound(brr)
str = brr(i, 2) & "|" & brr(i, 3) & "|" & brr(i, 7)
If Not dc2.Exists(str) Then
m = m + dc1(brr(i, 3)).Count
End If
dc2(str) = dc2(str) + brr(i, 5)
Next
ReDim brr(1 To m, 1 To 10)
m = 0
For Each str In dc2.keys
dd = Split(str, "|")
aa = dd(1)
For Each bb In dc1(aa).keys
m = m + 1
brr(m, 1) = aa
brr(m, 2) = bb
brr(m, 3) = arr(dc1(aa)(bb), 3)
brr(m, 4) = arr(dc1(aa)(bb), 4)
brr(m, 5) = arr(dc1(aa)(bb), 5)
brr(m, 6) = arr(dc1(aa)(bb), 6)
brr(m, 7) = dc2(str)
brr(m, 8) = brr(m, 6) * brr(m, 7)
brr(m, 9) = dd(2)
brr(m, 10) = dd(0)
Next
Next
Sheet4.[A3].Resize(UBound(brr), 10) = brr
End Sub
|