|
- Sub 统计()
- Dim arr, brr
- Dim m, i, j, x, k, t
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- [B18:G20] = Empty
- arr = Range("I2:J12")
- For i = 2 To UBound(arr)
- If Not d.exists(arr(i, 2)) Then
- m = 1
- ReDim brr(1 To 1, 1 To m)
- Else
- brr = d(arr(i, 2))
- m = UBound(brr, 2) + 1
- ReDim Preserve brr(1 To 1, 1 To m)
- End If
- brr(1, m) = arr(i, 1)
- d(arr(i, 2)) = brr
- Next
- k = d.keys
- t = d.items
- arr = Range("A1:G14")
- For i = 2 To UBound(arr)
- For x = 0 To d.Count - 1
- For j = 1 To UBound(t(x), 2)
- If arr(i, 1) = t(x)(1, j) Then arr(i, 1) = k(x)
- Next
- Next
- Next
- d.RemoveAll
- For i = 2 To UBound(arr)
- For j = 2 To UBound(arr, 2)
- d(arr(i, 1) & arr(1, j)) = d(arr(i, 1) & arr(1, j)) + arr(i, j)
- Next
- Next
- arr = Range("A17:G20")
- For i = 2 To UBound(arr)
- For j = 2 To UBound(arr, 2)
- arr(i, j) = d(arr(i, 1) & arr(1, j))
- Next
- Next
- Range("A17").Resize(UBound(arr), UBound(arr, 2)) = arr
- Set d = Nothing
- End Sub
复制代码 |
|