求助，VBA中用字典代替SUMIFS

szctc12321

各位大神，我用SUMIFS写的，但是数据量比较大，一运行就卡死
如何用字典代替SUMIFS进行求和？

求和区域是“零售数量”，条件是“仓名称”和“条码”

chxw68

欢迎新朋友。

yynrzwh

sss.zip (115.19 KB, 下载次数: 14)

2024-4-30 11:28 上传

点击文件名下载附件

cyq4896

参与一下...

swl4561255

1. Sub test()
   
2. Application.ScreenUpdating = False
   
3. arr = Sheets("sheet1").Range("A1").CurrentRegion
   
4. brr = Range("A1").CurrentRegion
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. For i = 2 To UBound(arr)
   
7.     d(arr(i, 1) & arr(i, 2)) = arr(i, 3) & "-" & arr(i, 4)
   
8. Next
   
9. For j = 3 To UBound(brr)
   
10.     For k = 2 To UBound(brr, 2) - 1 Step 2
    
11.         If d.exists(brr(1, k) & brr(j, 1)) Then
    
12.             brr(j, k) = Split(d(brr(1, k) & brr(j, 1)), "-")(0)
    
13.             brr(j, k + 1) = Split(d(brr(1, k) & brr(j, 1)), "-")(1)
    
14.         End If
    
15.     Next
    
16. Next
    
17. [A1].Resize(UBound(brr), UBound(brr, 2)) = brr
    
18. Set d = Nothing
    
19. Application.ScreenUpdating = True
    
20. End Sub
    

复制代码

jjmysjg

cyq4896 发表于 2024-4-30 11:51
参与一下...

附件不能下载

ykcbf1100

全表自动生成，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.30
   
2.     Dim arr, brr, d, s
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6. 
   
7.     Set sh = ThisWorkbook.Sheets("Sheet2")
   
8.     bt = [{"销","存"}]
   
9.     m = 2: n = 1
   
10.     On Error Resume Next
    
11.     With Sheets("Sheet1")
    
12.         r = .Cells(Rows.Count, 1).End(3).Row
    
13.         arr = .[a1].Resize(r, 4)
    
14.         ReDim brr(1 To UBound(arr), 1 To 300)
    
15.         brr(1, 1) = arr(1, 2)
    
16.         For i = 2 To UBound(arr)
    
17.             If arr(i, 1) <> Empty Then
    
18.                 s = CStr(arr(i, 2))
    
19.                 If Not d.exists(s) Then
    
20.                     m = m + 1
    
21.                     d(s) = m
    
22.                     brr(m, 1) = s
    
23.                 End If
    
24.                 s = CStr(arr(i, 1))
    
25.                 If Not d.exists(s) Then
    
26.                     n = n + 2
    
27.                     d(s) = n
    
28.                     brr(1, n - 1) = s
    
29.                     brr(2, n - 1) = bt(1): brr(2, n) = bt(2)
    
30.                 End If
    
31.                 r = d(CStr(arr(i, 2))): c = d(CStr(arr(i, 1)))
    
32.                 brr(r, c - 1) = brr(r, c - 1) + arr(i, 3)
    
33.                 brr(r, c) = brr(r, c) + arr(i, 4)
    
34.             End If
    
35.         Next
    
36.     End With
    
37.     With sh
    
38.         .UsedRange.Clear
    
39.         .Columns(1).NumberFormatLocal = "@"
    
40.         .[a1].Resize(m, n) = brr
    
41.         .[a1].Resize(2, n).Interior.Color = 49407
    
42.         .[a3].Resize(m - 2, 1).Interior.Color = 5296274
    
43.         .[a1].Resize(2).Merge
    
44.         For j = 2 To n Step 2
    
45.             .Cells(1, j).Resize(1, 2).Merge
    
46.         Next
    
47.         ActiveWindow.DisplayZeros = False
    
48.         Set Rng = .[a1].Resize(m, n)
    
49.         With Rng
    
50.             .Borders.LineStyle = 1
    
51.             .HorizontalAlignment = xlCenter
    
52.             .VerticalAlignment = xlCenter
    
53.             With .Font
    
54.                 .Name = "微软雅黑"
    
55.                 .Size = 11
    
56.             End With
    
57.         End With
    
58.     End With
    
59.     Set d = Nothing
    
60.     Application.ScreenUpdating = True
    
61. End Sub
    

复制代码

cyq4896

jjmysjg 发表于 2024-4-30 12:43
附件不能下载

刚试了试可以下载呀

Qs18

Sub test()
Dim dic As Object, arr, i, t
Set dic = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1").CurrentRegion.Value
For i = 2 To UBound(arr)
    t = arr(i, 1) & arr(i, 2)
    If Not dic.exists(t) Then
        dic(t) = arr(i, 3)
        dic2(t) = arr(i, 4)
    Else
        dic(t) = dic(t) + arr(i, 3)
        dic2(t) = dic2(t) + arr(i, 4)
    End If
Next i
j = 3
With Sheet2
    Do While .Range("a" & j) <> ""
    .Range("b" & j) = dic(.Range("b1") & .Range("a" & j))
    .Range("c" & j) = dic2(.Range("b1") & .Range("a" & j))
    .Range("d" & j) = dic(.Range("d1") & .Range("a" & j))
    .Range("e" & j) = dic2(.Range("d1") & .Range("a" & j))
    .Range("f" & j) = dic(.Range("f1") & .Range("a" & j))
    .Range("g" & j) = dic2(.Range("f1") & .Range("a" & j))
    .Range("h" & j) = dic(.Range("h1") & .Range("a" & j))
    .Range("i" & j) = dic2(.Range("h1") & .Range("a" & j))
    j = j + 1
    Loop
End With
End Sub