|
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("提取名单")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a2:n" & r)
- End With
- For i = 1 To UBound(arr)
- If Not d.exists(arr(i, 2)) Then
- Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
- End If
- If Not d(arr(i, 2)).exists(arr(i, 12)) Then
- Set d(arr(i, 2))(arr(i, 12)) = CreateObject("scripting.dictionary")
- End If
- d(arr(i, 2))(arr(i, 12))(arr(i, 5)) = d(arr(i, 2))(arr(i, 12))(arr(i, 5)) + arr(i, 7)
- Next
- With Worksheets("2020汇总")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- c = .Cells(3, .Columns.Count).End(xlToLeft).Column
- .Range("b4").Resize(r - 3, c - 1).ClearContents
- arr = .Range("a2").Resize(r - 1, c)
- For i = 3 To UBound(arr)
- If d.exists(arr(i, 1)) Then
- For j = 2 To UBound(arr, 2) Step 2
- If d(arr(i, 1)).exists(arr(1, j)) Then
- arr(i, j) = d(arr(i, 1))(arr(1, j)).Count
- arr(i, j + 1) = Application.Sum(d(arr(i, 1))(arr(1, j)).items)
- End If
- Next
- End If
- Next
- .Range("a2").Resize(UBound(arr), UBound(arr, 2)) = arr
- End With
- End Sub
复制代码 |
评分
-
2
查看全部评分
-
|