几万行的数据，现有的公式慢，求助VBA的老师

gaveout

上午发了一个帖，也是类似的问题，但是我的VBA真的渣，也高估了自己，所以没办法只有把表格发上来，再次求助了。附件中的批注更清楚。编号很多，不止附件中的那几十个。谢谢老师。

hefuqing

1. Sub ddd()
   
2. Dim brr()
   
3. arr = Sheet2.Range("a1:w" & Sheet2.Range("g65536").End(xlUp).Row)
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. For i = 1 To UBound(arr)
   
8. d(arr(i, 7) & "-" & arr(i, 15)) = d(arr(i, 7) & "-" & arr(i, 15)) + arr(i, 19)
   
9. d1(arr(i, 7) & "-" & arr(i, 15)) = d1(arr(i, 7) & "-" & arr(i, 15)) + arr(i, 20)
   
10. d2(arr(i, 7) & "-" & arr(i, 15)) = d2(arr(i, 7) & "-" & arr(i, 15)) + arr(i, 23)
    
11. Next i
    
12. k = d.keys
    
13. t = d.items
    
14. t1 = d1.items
    
15. t2 = d2.items
    
16. ReDim brr(1 To d.Count, 1 To 5)
    
17. For i = 0 To d.Count - 1
    
18. n = n + 1
    
19. brr(n, 1) = Split(k(i), "-")(0)
    
20. brr(n, 2) = Split(k(i), "-")(1)
    
21. brr(n, 3) = t(i)
    
22. brr(n, 4) = t1(i)
    
23. brr(n, 5) = t2(i)
    
24. Next
    
25. m = 2
    
26. For i = 2 To UBound(brr)
    
27. m = m + 1
    
28. Sheet3.Cells(m, 5) = brr(i, 1)
    
29. For j = 7 To 9
    
30. If brr(i, 2) = Sheet3.Cells(2, j) Then
    
31. Sheet3.Cells(m, j) = brr(i, 2)
    
32. End If
    
33. Next j
    
34. Sheet3.Cells(m, 10) = brr(i, 3)
    
35. Sheet3.Cells(m, 11) = brr(i, 4)
    
36. Sheet3.Cells(m, 15) = brr(i, 5)
    
37. Next i
    
38. End Sub
    

复制代码

gaveout

hefuqing 发表于 2018-8-23 19:45

感谢老师的帮助，谢谢您，一会我下载下来试试，祝您与家人身体健康，工作顺利，天天开心，再次谢谢您。

gaveout

hefuqing 发表于 2018-8-23 19:45

老师，如果我暂时不需要分开土质，即汇总时车辆编号只显示一个，总车数、总方量、金额不分土质，算在一起该修改什么代码？如果再加一个开关可以吗？

hefuqing

gaveout 发表于 2018-8-23 22:23
老师，如果我暂时不需要分开土质，即汇总时车辆编号只显示一个，总车数、总方量、金额不分土质，算在一起 ...

没有理解你的意思

hefuqing

1. Sub ddd()
   
2. Dim brr()
   
3. arr = Sheet2.Range("a1:w" & Sheet2.Range("g65536").End(xlUp).Row)
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. For i = 1 To UBound(arr)
   
8. d(arr(i, 7)) = d(arr(i, 7)) + arr(i, 19)
   
9. d1(arr(i, 7)) = d1(arr(i, 7)) + arr(i, 20)
   
10. d2(arr(i, 7)) = d2(arr(i, 7)) + arr(i, 23)
    
11. Next i
    
12. k = d.keys
    
13. t = d.items
    
14. t1 = d1.items
    
15. t2 = d2.items
    
16. m = 2
    
17. For i = 1 To d.Count - 1
    
18. m = m + 1
    
19. Sheet3.Cells(m, 5) = k(i)
    
20. Sheet3.Cells(m, 10) = t(i)
    
21. Sheet3.Cells(m, 11) = t1(i)
    
22. Sheet3.Cells(m, 15) = t2(i)
    
23. Next i
    
24. End Sub

复制代码

gaveout

hefuqing 发表于 2018-8-24 09:16

感谢老师的帮助，谢谢您。完美解决了我的问题，再次拜谢您的热心帮助。