|
Sub 统计()
Dim arr, brr, crr()
Dim r, m, i, j, k, t, s
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheet1
r = .Cells(.Rows.Count, 5).End(xlUp).Row
arr = .Range("E4:W" & r)
End With
For i = 1 To UBound(arr)
s = arr(i, 1) & "/" & arr(i, 3)
If Not d.exists(s) Then
m = 1
ReDim brr(1 To 1, 1 To m)
Else
brr = d(s)
m = UBound(brr, 2) + 1
ReDim Preserve brr(1 To 1, 1 To m)
End If
brr(1, m) = arr(i, 19)
d(s) = brr
Next
k = d.keys
t = d.items
ReDim Preserve crr(1 To d.Count, 1 To 7)
For j = 0 To d.Count - 1
crr(j + 1, 1) = Split(k(j), "/")(0)
crr(j + 1, 2) = Split(k(j), "/")(1)
For i = 1 To UBound(t(j), 2)
crr(j + 1, i + 3) = t(j)(1, i)
Next
Next
Sheet2.Range("G3:M65536") = ""
Sheet2.Range("G3").Resize(UBound(crr), UBound(crr, 2)) = crr
Set d = Nothing
End Sub |
|