|
- Sub Macro1()
- Dim arr, brr, crr, d, d2, i&, zf$, s&, n&, j%
- Set d = CreateObject("scripting.dictionary")
- Set d2 = CreateObject("scripting.dictionary")
- arr = Range("a2").CurrentRegion
- ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
- For i = 2 To UBound(arr)
- d2(arr(i, 1)) = ""
- zf = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)
- If Not d.exists(zf) Then
- s = s + 1
- d(zf) = s
- For j = 1 To UBound(arr, 2)
- brr(s, j) = arr(i, j)
- Next
- Else
- n = d(zf)
- brr(n, 4) = brr(n, 4) + arr(i, 4)
- End If
- Next
- d.RemoveAll
- For i = 1 To s
- zf = brr(i, 1) & "," & brr(i, 3)
- If Not d.exists(zf) Then
- d(zf) = brr(i, 4)
- Else
- If brr(i, 4) > d(zf) Then d(zf) = brr(i, 4)
- End If
- Next
- crr = [f2:h30000]
- a = d2.keys
- For i = 0 To d2.Count - 1
- crr(i + 2, 1) = a(i)
- For j = 2 To 3
- zf = a(i) & "," & crr(1, j)
- crr(i + 2, j) = d(zf)
- Next
- Next
- [f3:h65536] = ""
- Range("f2").Resize(d.Count + 1, 3) = crr
- End Sub
复制代码 |
评分
-
查看全部评分
|