相同帐号的正负值抵消，如何提高VBA执行速度？

grf1973

1. Sub 排序后对冲()
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     r = [a65536].End(3).Row
   
5.     Range("a1:d" & r).Copy [f1]   '数据复制
   
6.     Range("f2:i" & r).Sort key1:=[g2]       '按帐号排序
   
7.     arr = Range("f1:i" & r)        'arr为源数组
   
8.     For i = 2 To UBound(arr)
   
9.         x = "'" & arr(i, 2)
   
10.        d(x) = d(x) & "+" & i        '以账号为key，以账号所在行数为item（字符串累加）
    
11.     Next
    
12.     dk = d.keys: dt = d.items
    
13.     For i = 0 To UBound(dk)
    
14.         x = Split(dt(i), "+")      '行数分列
    
15.         s1 = Val(x(1)): s2 = Val(x(UBound(x)))      's1为该账号的起始行，s2为结束行
    
16.         For j = s1 To s2 - 1              '在起始行和结束行之间对冲，如果对冲，把金额置0
    
17.             For k = j + 1 To s2
    
18.                 If arr(j, 4) + arr(k, 4) = 0 Then
    
19.                     arr(k, 4) = 0: arr(j, 4) = 0
    
20.                     Exit For
    
21.                 End If
    
22.             Next
    
23.         Next
    
24.     Next
    
25.     ReDim brr(1 To UBound(arr), 1 To 4)        'brr为显示数组
    
26.     brr(1, 1) = arr(1, 1): brr(1, 2) = arr(1, 2)
    
27.     brr(1, 3) = arr(1, 3): brr(1, 4) = arr(1, 4)
    
28.     p = 1
    
29.     For i = 2 To UBound(arr)
    
30.         If arr(i, 4) <> 0 Then          '如果金额不为0（表示未经过对冲），则存入Brr用于最终显示
    
31.             p = p + 1
    
32.             brr(p, 1) = arr(i, 1): brr(p, 2) = arr(i, 2)
    
33.             brr(p, 3) = arr(i, 3): brr(p, 4) = arr(i, 4)
    
34.         End If
    
35.     Next
    
36.     Range("f:i").ClearContents
    
37.     [f1].Resize(p, 4) = brr         '显示
    
38.     Range("f2:i" & r).Sort key1:=[f2]        '重新按序号排序
    
39.     Application.ScreenUpdating = True
    
40. End Sub
    

复制代码

grf1973

请看附件。

grf1973

给个更快的，少了两重排序。

1. Sub 分组后对冲()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = [a1].CurrentRegion  'arr为源数组
   
4.     ra = UBound(arr)
   
5.     For i = 2 To ra       '以账号为key，以账号所在行数为item（字符串累加）
   
6.          d(arr(i, 2)) = d(arr(i, 2)) & "," & i
   
7.     Next
   
8.    
   
9.     dk = d.keys: dt = d.items
   
10.     p = 1
    
11.     For i = 0 To UBound(dk)
    
12.       x = Split(dt(i), ",")    '行数分列
    
13.       s = UBound(x)
    
14.       For j = 1 To s - 1      '在账号对应的各行之间对冲，如果对冲，把对应行的金额置0
    
15.           h1 = Val(x(j)): a1 = arr(h1, 4)         '表示行h1对应的金额
    
16.           For k = j + 1 To s
    
17.               h2 = Val(x(k)): a2 = arr(h2, 4)    '表示行h2对应的金额
    
18.               If a1 + a2 = 0 Then
    
19.                   arr(h1, 4) = 0          '对应行的金额置0
    
20.                   arr(h2, 4) = 0
    
21.                   Exit For
    
22.               End If
    
23.           Next
    
24.       Next
    
25.     Next
    
26.          
    
27.     ReDim brr(1 To UBound(arr), 1 To 4)        'brr为显示数组
    
28.       brr(1, 1) = arr(1, 1): brr(1, 2) = arr(1, 2)
    
29.       brr(1, 3) = arr(1, 3): brr(1, 4) = arr(1, 4)
    
30.       p = 1
    
31.       For i = 2 To UBound(arr)
    
32.           If arr(i, 4) <> 0 Then          '如果金额不为0（表示未经过对冲），则存入Brr用于最终显示
    
33.               p = p + 1
    
34.               brr(p, 1) = arr(i, 1): brr(p, 2) = arr(i, 2)
    
35.               brr(p, 3) = arr(i, 3): brr(p, 4) = arr(i, 4)
    
36.           End If
    
37.       Next
    
38.               
    
39.     [f1].Resize(p, 4) = brr
    
40. End Sub

复制代码

grf1973

请看附件。分组对冲0.15秒，排序对冲0.20秒，快了25%。如果数据量再大点的话，估计对比会更明显。

ghq200101

grf1973 发表于 2014-2-11 10:08
请看附件。

由衷的感谢，完全达到我理解中的要求，速度快，代码精练，佩服！{:soso_e179:}