一个统计问题

ynymzzr

由于数据量较大，公式太慢并且卡，请高手给予解决，要求见附件。

jhwei2

要求不清楚，不知道要怎么统计

鄂龙蒙

1. Sub 汇总()
   
2.     Range("A5:V10000").ClearContents
   
3.     Dim m, n, i, j, arr, brr, ar, br(), cr()
   
4.     Dim d As Object, da As Object, k, kk, t, tt
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set da = CreateObject("scripting.dictionary")
   
7.     ar = Range("C4:U4")
   
8.     For i = 1 To UBound(ar, 2): da(ar(1, i)) = i: Next
   
9.     arr = Sheet1.Range("A1").CurrentRegion
   
10.     For i = 2 To UBound(arr)
    
11.         If Not d.exists(arr(i, 3)) Then
    
12.             m = 1: ReDim brr(1 To 22, 1 To m)
    
13.         Else
    
14.             brr = d(arr(i, 3)): m = UBound(brr, 2) + 1
    
15.             ReDim Preserve brr(1 To 22, 1 To m)
    
16.         End If
    
17.         If da.exists(arr(i, 4)) Then brr(da(arr(i, 4)) + 2, m) = arr(i, 10)
    
18.         d(arr(i, 3)) = brr
    
19.     Next
    
20.      k = d.keys: t = d.items
    
21.     For x = 0 To d.Count - 1
    
22.         For i = 1 To UBound(t(x), 2)
    
23.             n = n + 1: ReDim Preserve br(1 To 22, 1 To n)
    
24.             br(1, n) = k(x)
    
25.             For j = 2 To 22: br(j, n) = t(x)(j, i): Next
    
26.         Next
    
27.     Next
    
28.     m = 0: d.RemoveAll
    
29.     arr = Sheet2.UsedRange
    
30.     For i = 1 To UBound(br, 2)
    
31.         s = br(1, i)
    
32.         If d(s) = "" Then
    
33.             m = m + 1: ReDim Preserve cr(1 To 22, 1 To m)
    
34.             d(s) = m: cr(1, m) = s
    
35.             For j = 3 To 21: cr(j, m) = br(j, i): Next
    
36.         Else
    
37.             For j = 3 To 21: cr(j, d(s)) = cr(j, d(s)) + br(j, i): Next
    
38.         End If
    
39.         For j = 2 To UBound(arr)
    
40.             If cr(1, m) = arr(j, 1) Then cr(22, m) = arr(j, 2)
    
41.         Next
    
42.      Next
    
43.      For i = 1 To m
    
44.         For j = 3 To 22: cr(2, i) = cr(2, i) + cr(j, i): Next
    
45.      Next
    
46.     [A5].Resize(m, 22) = Application.Transpose(cr)
    
47.     Set d = Nothing
    
48. End Sub

复制代码

ynymzzr

谢谢，两位高手，测试，符合要求。