跨工作表多条件求和，数据太多太慢了求大佬帮助

天舞·紫嫣

求大佬们帮忙看一下这个表如何能快速的跨表求和啊，运算速度太慢了呜呜呜


如果方便的话代码能不能加上注释呀，感谢各位大佬的帮助，23333333

ykcbf1100

附件请参考。。。

ykcbf1100

1. Sub ykcbf()    '//2023.3.17
   
2.     Dim arr, brr(1 To 100000, 1 To 10), d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     arr = Sheets("应发比例").[a1].CurrentRegion
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 3)
   
9.         d1(s) = arr(i, 4)
   
10.     Next
    
11.     arr = Sheets("2022全年明细").UsedRange
    
12.     For i = 2 To UBound(arr)
    
13.         If arr(i, 2) <> Empty Then
    
14.             yf = Right(CStr(arr(i, 2)), 2)
    
15.             s = arr(i, 4) & "|" & arr(i, 15) & "|" & yf
    
16.             If Not d.exists(s) Then
    
17.                 d(s) = Array(arr(i, 26), d1(arr(i, 25)), arr(i, 22))
    
18.             Else
    
19.                 t = d(s)
    
20.                 t(0) = t(0) + arr(i, 26)
    
21.                 t(2) = t(2) + arr(i, 22)
    
22.                 d(s) = t
    
23.             End If
    
24.             s2 = arr(i, 4) & "|" & arr(i, 15)
    
25.             d2(s2) = ""
    
26.         End If
    
27.     Next
    
28.     t = d.items
    
29.     For Each k In d2.keys
    
30.         m = m + 1
    
31.         brr(m, 1) = Split(k, "|")(0)
    
32.         brr(m, 3) = Split(k, "|")(1)
    
33.     Next
    
34.     On Error Resume Next
    
35.     With Sheets("2022酬金发放核对表")
    
36.         .UsedRange.Offset(1).Clear
    
37.         .Columns(4).NumberFormatLocal = "@"
    
38.         .[b2].Resize(m, 3) = brr
    
39.         c = .Cells(1, Columns.Count).End(xlToLeft).Column
    
40.         arr = .[a1].Resize(m + 1, c)
    
41.         For i = 2 To UBound(arr)
    
42.             For j = 5 To c Step 4
    
43.                 s = arr(i, 2) & "|" & arr(i, 4) & "|" & CStr(arr(1, j))
    
44.                 If d.exists(s) Then
    
45.                     arr(i, j) = d(s)(0)
    
46.                     arr(i, j + 1) = Format(d(s)(1), "0.00%")
    
47.                     arr(i, j + 2) = Format(d(s)(0) / d(s)(2), "0.00%")
    
48.                 End If
    
49.             Next
    
50.         Next
    
51.         .[a1].Resize(m + 1, c) = arr
    
52.         .[a1].Resize(m + 1, c).Borders.LineStyle = 1
    
53.     End With
    
54. End Sub

复制代码

代码如下：

天舞·紫嫣

ykcbf1100 发表于 2023-3-17 11:28
附件请参考。。。

谢谢大佬，有个问题就是其他空白列也是有数据的，现在这个都是清空的，能不能保留原有数据

grf1973

多用几个字典。

天舞·紫嫣

grf1973 发表于 2023-3-17 11:47
多用几个字典。

谢谢亲，能满足需要，想问下就是D列号码列运行之后，超长号码和0开头的号码就变了，这个应该怎么改啊

天舞·紫嫣

ykcbf1100 发表于 2023-3-17 11:28
附件请参考。。。

谢谢亲，速度超级快，想问下其他空列应该是有数据的，如何能不清空哈

ykcbf1100

天舞·紫嫣 发表于 2023-3-17 12:05
谢谢亲，速度超级快，想问下其他空列应该是有数据的，如何能不清空哈

如果不需要清空的话，那代码要少很多。

天舞·紫嫣

ykcbf1100 发表于 2023-3-17 12:11
如果不需要清空的话，那代码要少很多。

嗯嗯，不需要排序和清空有数据的列，老师能改一下吗

ykcbf1100

天舞·紫嫣 发表于 2023-3-17 12:13
嗯嗯，不需要排序和清空有数据的列，老师能改一下吗

我看一下。