[已解决]对字典基本用法的提速

爱疯

test的作用：在sheet2的A列，查找sheet1的A列数据。如果找到，就在B列输入有；否则输入无。
我的机子上test的运行时间要20秒。请问可否提速？谢谢！


已绑帐号和总帐号的比对.rar (1.09 MB, 下载次数: 152)

2014-1-9 17:02 上传

点击文件名下载附件
Sub test()
    Dim A, B, d, i, r
    Application.ScreenUpdating = False
    A = Sheet1.Range("a1").CurrentRegion
    B = Sheet2.Range("a1").CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(A)
        d(A(i, 1)) = ""
    Next
    r = UBound(B)
    For i = 1 To r
        If d.exists(B(i, 1)) Then B(i, 1) = "有" Else B(i, 1) = "无"
    Next i
    Sheet2.Range("b1:b" & r) = B
End Sub


Sub test2()
    Dim t
    t = Timer
    test
    MsgBox Timer - t
End Sub

最佳答案

月排行榜 / 总排行榜

香川群子

2014-1-22 14:23

对关键词拆分成二部分以后进行字典嵌套处理的算法：

字典处理部分时间略有增加，（要分二段进行处理）
但后面比对处理时速度更快了。（比对数据中前半部分不符合项越多速度越快）

1. Sub test3()
   
2.     Dim i&, k&, l&, s$, s1$, s2$
   
3.     tms = Timer
   
4.     'l = 0 '此参数为拆分参数，设置l=0时就相当于通常只使用1个字典的用法。
   
5.    l = 3 ' 通常设置l=3 或l=4较好。
   
6.         ' 但如设置l很大本例设置l=8时使得第一字典项很多就毫无效果了，反而速度更慢会死机
   
7.    
   
8.     arr = Sheet1.Range("a1").CurrentRegion
   
9.     Set d = CreateObject("Scripting.Dictionary")
   
10.     For i = 1 To UBound(arr)
    
11.         s = arr(i, 1): s1 = Left(s, l): s2 = Mid(s, l + 1)
    
12.         If Not d.Exists(s1) Then Set d(s1) = CreateObject("Scripting.Dictionary")
    
13.         d(s1)(s2) = ""
    
14.     Next
    
15.     krr = d.keys
    
16.     For i = 1 To d.Count
    
17.         k = k + d(krr(i - 1)).Count
    
18.     Next
    
19.     MsgBox Format(Timer - tms, "0.000s ") & d.Count & vbCr & k: tms = Timer
    
20. 
    
21.     m = Sheet2.Range("a1").End(4).Row
    
22.     arr = Sheet2.Range("a1").Resize(m)
    
23.     For i = 1 To m
    
24.         s = arr(i, 1): s1 = Left(s, l): s2 = Mid(s, l + 1)
    
25.         If Not d.Exists(s1) Then arr(i, 1) = "无" Else If d(s1).Exists(s2) Then arr(i, 1) = "有" Else arr(i, 1) = "无"
    
26. 
    
27.         '上面是简写,下面是正规的If结构        
    
28. '        If d.Exists(s1) Then
    
29. '            If d(s1).Exists(s2) Then
    
30. '                arr(i, 1) = "有"
    
31. '            Else
    
32. '                arr(i, 1) = "无"
    
33. '            End If
    
34. '        Else
    
35. '            arr(i, 1) = "无"
    
36. '        End If
    
37.     Next
    
38.     MsgBox Format(Timer - tms, "0.000s ") & m
    
39.    
    
40. '    Sheet2.Range("d1").Resize(m) = arr '输出到工作表
    
41. End Sub

复制代码

爱疯你自己比较一下吧。

跳转到最佳答案楼层

上清宫主

已差不多了

爱疯

上清宫主 发表于 2014-1-9 21:46
已差不多了

谢谢上清！
可能再提速的方法就麻烦了，也难的懂吧。

amesman

换台性能好的电脑吧

CheryBTL

爱疯 发表于 2014-1-9 21:51
谢谢上清！
可能再提速的方法就麻烦了，也难的懂吧。

晚上我自己测试的结果：
重新定义一个文本型的结果数组，可以省2~3秒。

CheryBTL

爱疯 发表于 2014-1-9 21:51
谢谢上清！
可能再提速的方法就麻烦了，也难的懂吧。

重新定义一个结果数组
并把结果数组定义成一个字符串数组，可以减2~3秒。

爱疯

amesman 发表于 2014-1-9 23:55
换台性能好的电脑吧

谢谢！
现在的机子，比以前用的好很多了

爱疯

CheryBTL 发表于 2014-1-10 00:54
重新定义一个结果数组
并把结果数组定义成一个字符串数组，可以减2~3秒。

谢谢！
我试了下，只快了0.5秒。
实际应用中碰到这种情况，不知道有没有其它方法可改善

CheryBTL

爱疯 发表于 2014-1-10 09:04
谢谢！
我试了下，只快了0.5秒。
实际应用中碰到这种情况，不知道有没有其它方法可改善

数据若有按升序或降序排列的话，可能会快一点，否则就只能逐一比较，但可以增加一个条件，在包含时输入为“有”的同时，跳出 循环。

感觉字典也是这么用的，也是按某个比较高效的算法来实现匹配的。

xdwy81129

测试了下，改用  If d(B(i, 1)) + 1 = 1 Then  来判断，结果是24秒
楼主原来的是19.3秒

所以确定楼主的方法的最快的，而且电脑业是很不错的，我配置的CPU是i5-3570，不知道楼主的cpu是什么型号