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

ghq200101

AVEL 发表于 2014-2-10 11:03
4楼代码不可以么？

4楼代码提取出来的是各帐号的合计值，不是一条条记录，谢谢！

AVEL

ghq200101 发表于 2014-2-10 11:08
4楼代码提取出来的是各帐号的合计值，不是一条条记录，谢谢！

那你做个例子出来 方便大家理解。。

ghq200101

我发了一个附件，请作参考，不过数据量不大，如果我在2楼的附表中作就很慢，不知是否明白，谢谢！

grf1973

1. Sub tt1()
   
2.   Set d = CreateObject("Scripting.Dictionary")
   
3.   arr = [a1].CurrentRegion
   
4.   ra = UBound(arr)
   
5.   For i = 2 To ra - 1
   
6.         For j = i + 1 To ra
   
7.             If arr(i, 1) = arr(j, 1) And arr(i, 2) + arr(j, 2) = 0 Then
   
8.                 arr(i, 1) = arr(ra - 1, 1): arr(i, 2) = arr(ra - 1, 2)
   
9.                 arr(j, 1) = arr(ra, 1): arr(j, 2) = arr(ra, 2)
   
10.                 ra = ra - 2
    
11.                 i = i - 1
    
12.                 Exit For
    
13.             End If
    
14.         Next
    
15.   Next
    
16.   
    
17.   [f1].Resize(ra, 2) = arr
    
18. End Sub
    

复制代码

grf1973

7655条记录筛选后剩余7449条。不知道对不对。反正两边求和是一样的。

ghq200101

grf1973 发表于 2014-2-10 11:45

非常感谢，运行快好多了，能否还有更快的办法吗？

grf1973

1. Sub tt2()
   
2.   Set d = CreateObject("Scripting.Dictionary")
   
3.   arr = [a1].CurrentRegion
   
4.   ra = UBound(arr)
   
5.   For i = 2 To ra - 1
   
6.        d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)
   
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.         If s > 1 Then
    
15.             For j = 1 To s - 1
    
16.                 a1 = Val(x(j))
    
17.                 For k = j + 1 To s
    
18.                     a2 = Val(x(k))
    
19.                     If a1 + a2 = 0 Then
    
20.                         x(j) = x(s - 1): x(k) = x(s)
    
21.                         s = s - 2
    
22.                         j = j - 1
    
23.                         Exit For
    
24.                     End If
    
25.                 Next
    
26.             Next
    
27.         End If
    
28.         If s >= 1 Then
    
29.             For t = 1 To s
    
30.                 p = p + 1
    
31.                 arr(p, 1) = dk(i)
    
32.                 arr(p, 2) = x(t)
    
33.             Next
    
34.         End If
    
35.     Next
    
36.             
    
37.   [I1].Resize(p, 2) = arr
    
38. End Sub
    

复制代码

速度是快了，但结果貌似有点不对，正在查找原因中。。。。。。。。

grf1973

下面的代码结果是对的，原先的找不出不对的原因。。。。。

1. Sub 先分组再对冲()
   
2.   Set d = CreateObject("Scripting.Dictionary")
   
3.   arr = [a1].CurrentRegion
   
4.   ra = UBound(arr)
   
5.   For i = 2 To ra
   
6.        d(arr(i, 1)) = d(arr(i, 1)) & "," & arr(i, 2)   '以帐号为key，金额放到对应的字典里
   
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
    
15.             a1 = Val(x(j))
    
16.             For k = j + 1 To s
    
17.                 a2 = Val(x(k))
    
18.                 If a1 <> 0 And a2 <> 0 And a1 + a2 = 0 Then
    
19.                     x(j) = 0: x(k) = 0
    
20.                     Exit For
    
21.                 End If
    
22.             Next
    
23.         Next
    
24.    
    
25.         For t = 1 To s
    
26.             If Val(x(t)) <> 0 Then
    
27.                 p = p + 1
    
28.                 arr(p, 1) = dk(i)
    
29.                 arr(p, 2) = Val(x(t))
    
30.             End If
    
31.         Next
    
32.     Next
    
33.   [f1].Resize(p, 2) = arr
    
34. End Sub

复制代码

grf1973

请看附件。

wdx223

1. Sub QC()
   
2. Dim dic, arr(), data, i As Long, k As Long, rs As Range, j As Long
   
3. 
   
4. Set dic = CreateObject("Scripting.Dictionary")
   
5. 
   
6. data = Sheet1.[A2:B7656]
   
7. For i = LBound(data) To UBound(data)
   
8.     If Not dic.exists(data(i, 1) & "" & Abs(data(i, 2))) Then
   
9.         k = k + 1
   
10.         dic(data(i, 1) & "" & Abs(data(i, 2))) = k
    
11.         ReDim Preserve arr(1 To 2, 1 To k)
    
12.     End If
    
13.     If data(i, 2) > 0 Then
    
14.         If arr(1, dic(data(i, 1) & "" & Abs(data(i, 2)))) = "" Then
    
15.             arr(1, dic(data(i, 1) & "" & Abs(data(i, 2)))) = i + 1
    
16.         Else
    
17.             arr(1, dic(data(i, 1) & "" & Abs(data(i, 2)))) = arr(1, dic(data(i, 1) & "" & Abs(data(i, 2)))) & "," & i + 1
    
18.         End If
    
19.     Else
    
20.         If arr(2, dic(data(i, 1) & "" & Abs(data(i, 2)))) = "" Then
    
21.             arr(2, dic(data(i, 1) & "" & Abs(data(i, 2)))) = i + 1
    
22.         Else
    
23.             arr(2, dic(data(i, 1) & "" & Abs(data(i, 2)))) = arr(2, dic(data(i, 1) & "" & Abs(data(i, 2)))) & "," & i + 1
    
24.         End If
    
25.     End If
    
26. Next i
    
27. 
    
28. For i = 1 To k
    
29.     If arr(1, i) <> "" And arr(2, i) <> "" Then
    
30.         For j = 0 To WorksheetFunction.Min(UBound(Split(arr(1, i), ",")), UBound(Split(arr(2, i), ",")))
    
31.             If rs Is Nothing Then
    
32.                 Set rs = Union(Rows(Split(arr(1, i), ",")(j)), Rows(Split(arr(2, i), ",")(j)))
    
33.             Else
    
34.                 Set rs = Union(rs, Rows(Split(arr(1, i), ",")(j)), Rows(Split(arr(2, i), ",")(j)))
    
35.             End If
    
36.                
    
37.         Next j
    
38.     End If
    
39. Next i
    
40. If Not rs Is Nothing Then rs.Delete
    
41. End Sub

复制代码

这样？只消除同一账号下金额互为正负的？