按订单号的分摊金额再分摊费用

XXZSP2

附档的需求我是用函数实现的，但是数据有时达到几十万条，运行不了，求助大佬帮忙看看能用VBA或别的办法实现不卡吗？感谢。

笨鸟飞不高

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.8.21
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("费用分摊")
   
5.         r = .Cells(Rows.Count, 3).End(3).Row
   
6.         arr = .[c1].Resize(r, 6)
   
7.     End With
   
8.     For i = 2 To UBound(arr)
   
9.         s = CStr(arr(i, 1))
   
10.         d1(s) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6))
    
11.     Next
    
12.     On Error Resume Next
    
13.     With Sheets("订单明细")
    
14.         r = .Cells(Rows.Count, "q").End(3).Row
    
15.         For i = 3 To r
    
16.             s = CStr(.Cells(i, "q").Value)
    
17.             d(s) = d(s) + .Cells(i, "ai").Value
    
18.         Next
    
19.         For i = 3 To r
    
20.             s = CStr(.Cells(i, "q").Value)
    
21.             n = 0
    
22.             t = d1(s)
    
23.             For j = 62 To 66
    
24.                 n = n + 1
    
25.                 .Cells(i, j) = .Cells(i, "ai").Value * t(n - 1) / d(s)
    
26.             Next
    
27.         Next
    
28.     End With
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码