求一段多条件求和汇总代码,数据量大不想用公式公式解决

Yedajun

求一段多条件求和汇总代码,数据量大不想用公式公式解决，先谢了！

ykcbf1100

全表自动生成。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.7
   
2.     Dim arr, brr, d, s
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     ReDim brr(1 To 100000, 1 To 100)
   
7.     m = 1: n = 1
   
8.     On Error Resume Next
   
9.     With Sheets("计分")
   
10.         brr(1, 1) = .[a1].Value
    
11.         r = .Cells(Rows.Count, 1).End(3).Row
    
12.         arr = .[a1].Resize(r, 3)
    
13.         For i = 2 To UBound(arr)
    
14.             If arr(i, 1) <> Empty Then
    
15.                 s = arr(i, 1)
    
16.                 If Not d.exists(s) Then
    
17.                     m = m + 1
    
18.                     d(s) = m
    
19.                     brr(m, 1) = s
    
20.                 End If
    
21.                 r = d(arr(i, 1))
    
22.                 s = arr(i, 2)
    
23.                 If Not d.exists(s) Then
    
24.                     n = n + 1
    
25.                     d(s) = n
    
26.                     brr(1, n) = s
    
27.                 End If
    
28.                 c = d(arr(i, 2))
    
29.                 brr(r, c) = brr(r, c) + arr(i, 3)
    
30.             End If
    
31.         Next
    
32.         .Columns("G:Z").Clear
    
33.         .[g1].Resize(m, n) = brr
    
34.         .[g1].Resize(1, n).Interior.Color = 49407
    
35.         .[g2].Resize(m - 1, 1).Interior.Color = 5296274
    
36.         ActiveWindow.DisplayZeros = False
    
37.         Set Rng = .[g1].Resize(m, n)
    
38.         With Rng
    
39.             .Borders.LineStyle = 1
    
40.             .HorizontalAlignment = xlCenter
    
41.             .VerticalAlignment = xlCenter
    
42.             With .Font
    
43.                 .Name = "微软雅黑"
    
44.                 .Size = 11
    
45.             End With
    
46.         End With
    
47.     End With
    
48.     Set d = Nothing
    
49.     Application.ScreenUpdating = True
    
50. End Sub
    

复制代码

sunya_0529

WPS里的JSA自定义函数练习一下——

Yedajun

ykcbf1100 发表于 2024-5-7 18:57
全表自动生成。

感谢了，这正是我想要的，不过还要慢慢消化！

Yedajun

ykcbf1100 发表于 2024-5-7 18:58
参与一下。。。

ReDim brr(1 To 100000, 1 To 100),能否问一下这句，如改成ReDim brr(1 To 100000, 1 To 500)为何就运行不了呢？能突破326吗？

Qs18

'试试
Sub test()
    Dim arr, dic, t, i, m, n
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        arr = .Range(Range("a2"), .Cells(Rows.Count, "c").End(xlUp))
        For i = 1 To UBound(arr)
            t = arr(i, 1) & arr(i, 2)
            If Not dic.exists(t) Then
                dic(t) = arr(i, 3)
            Else
                dic(t) = dic(t) + arr(i, 3)
            End If
        Next
        For m = 1 To 3
            For n = 1 To 3
              .Cells(m + 1, 7 + n) = dic(.Cells(m + 1, 7) & .Cells(1, 7 + n))
            
            Next
        Next
    End With
End Sub

ykcbf1100

Yedajun 发表于 2024-5-7 20:23
ReDim brr(1 To 100000, 1 To 100),能否问一下这句，如改成ReDim brr(1 To 100000, 1 To 500)为何就运行 ...

这样改理论上来说应该没问题。

明天会更好zj

这么规范的数据，首选透视表，秒解决问题

明天会更好zj