|
- Sub test()
- Dim arr, brr, dic As Object, d As Object, d1 As Object
- Dim i&, j&, k, crr, temp$, num&, ik, sm, n
- arr = Sheet3.Range("A1").CurrentRegion
- crr = Sheet1.Range("A1").CurrentRegion.Resize(, 4)
- Set dic = CreateObject("scripting.dictionary")
- Set d = CreateObject("scripting.dictionary")
- Set d1 = CreateObject("scripting.dictionary")
- ReDim brr(1 To 6)
- For i = 2 To UBound(arr)
- If Not dic.exists(arr(i, 2)) Then
- For j = 2 To UBound(arr, 2) - 4
- brr(j - 1) = arr(i, j)
- Next
- d1(arr(i, 2)) = brr
- Set dic(arr(i, 2)) = CreateObject("scripting.dictionary")
- End If
- dic(arr(i, 2))(arr(i, 1)) = arr(i, 10)
- Next i
- For i = 2 To UBound(crr)
- d(crr(i, 1)) = crr(i, 4)
- Next i
- ReDim brr(1 To dic.Count, 1 To 8)
- For i = 0 To dic.Count - 1
- temp = dic.keys()(i)
- For Each k In dic(temp).keys
- sm = sm + d(k) * dic(temp)(k)
- Next k
- If sm > 0 Then
- n = n + 1
- brr(n, 8) = sm
- For Each ik In d1(temp)
- num = num + 1
- brr(n, num) = ik
- Next ik
- num = 0
- sm = 0
- End If
- Next i
- Sheet2.[a2:h10000].ClearContents
- Sheet2.[a2].Resize(UBound(brr), UBound(brr, 2)) = brr
- Set dic = Nothing
- Set d = Nothing
- Set d1 = Nothing
- End Sub
复制代码 调整了,测试一下……
|
|