[已解决]求提速!!!

zhouxingyu

上清宫主 发表于 2016-4-22 10:36
整数类型的限制是不大于32767，如果超过，请用长整型。
直接把百分号去了

26000条数据可以运行,但有许多运算结果都不正确.
无论如何都谢谢你了!

上清宫主

不正确？
把规则写清楚；
把不正确的数据列出来

香川群子

楼主问题需要明确规则。

比如，T56789 既和前面的 T35689 有相同的5个=T5689，
但有和后面的 T25679 有另外一个相同的5个=T5679，

那么最后输出结果是保留第1个T5689呢，还是保留最后1个结果T5679呢？

…………
其它的问题我都解决了。估计我的速度最快。

香川群子

楼主如果对几万行数据进行双重循环检查，那么耗时是指数增加的，吃不消。

因此，最重要的问题：

如果某一行配对成功后，只需保留1个有效信息，那么检查方法可以改变。

…………
另外，如果首位字母无需检查，速度还可以加快。

香川群子

我的思路是这样子：

1. 外层从 i = 1 To m-1 开始检查、
2. 遍历 i2 = i+1 To m
只要匹配成功，就记录 i 、i2 并标记i2 为已匹配。

然后Next i 检查时，将忽略已经标记为匹配过的行，这样将大大提升速度。
但需要注意的时，如果新的 i 行在全部未标记行中检查完成后都没有匹配成功，
则需要再次遍历已标记匹配的行的集合，防止遗漏。

发生二次匹配时，不更改匹配结果。

以上。

  

上清宫主

香川群子 发表于 2016-4-22 14:34
我的思路是这样子：

1. 外层从 i = 1 To m-1 开始检查、

好象……我的代码就是这个思路。只是没去多伤脑细胞，致使细节上还有很多优化的地方
万来个数据不到1秒

上清宫主

他们原来的是用字典反复remove太耗时，所以不见优势
可不可以改进一下，不用remove，估计应该也不慢。
没去试

香川群子

如果对原始数据排序后再检查，可能效果更好。

香川群子

如果原始数据大部分能被多次匹配，那么检查速度应该是很快的。
估计3万行也就十几分钟吧。

附件更新，增加了生成35000行随机测试数据的代码。按我的算法，只需30秒左右即可检查完毕。
输出结果到工作表的时间不算在内。

grf1973

1. Dim xs, d
   
2. Sub tq()
   
3.     tt = Timer
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Range("h2:h" & [h65536].End(3).Row)
   
6.     ReDim brr(1 To UBound(arr), 1 To 3)
   
7.     For i = 1 To UBound(arr) - 1
   
8.         x = arr(i, 1)
   
9.         For j = i + 1 To UBound(arr)
   
10.             y = arr(j, 1)
    
11.             If brr(i, 1) = "" And brr(j, 1) = "" Then   '两原数均未匹配
    
12.                 If ISOK(x, y) Then     '看两原数是否相似数，有则匹配
    
13.                     xrr = Split(xs, ",")
    
14.                     brr(i, 1) = xrr(0): brr(i, 2) = xrr(1): brr(i, 3) = y
    
15.                     brr(j, 1) = xrr(0): brr(j, 2) = xrr(2): brr(j, 3) = x
    
16.                     i = i - 1     '指针上移，拿匹配数对照
    
17.                     Exit For
    
18.                 End If
    
19.             ElseIf brr(i, 1) <> "" And brr(j, 1) = "" Then       '上数已有匹配数，拿匹配数对照
    
20.                 p = brr(i, 1)
    
21.                 If ISGN(p, y) Then brr(j, 1) = p: brr(j, 2) = xs: brr(j, 3) = x
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     [i2].Resize(UBound(arr), 3) = brr
    
26.     MsgBox Timer - tt
    
27. End Sub
    
28. 
    
29. Function ISOK(x, y) As Boolean     '两原数x,y是否相似，并返回x,y的相似数xs
    
30.     xs = "": d.RemoveAll
    
31.     For i = 2 To Len(x)
    
32.         p = Left(x, i - 1) & Mid(x, i + 1)
    
33.         d(p) = i
    
34.     Next
    
35.         
    
36.     For i = 2 To Len(y)
    
37.         p = Left(y, i - 1) & Mid(y, i + 1)
    
38.         If d.exists(p) Then ISOK = True: Exit For
    
39.     Next
    
40.    
    
41.     If ISOK Then
    
42.         xs = p & "," & Mid(x, d(p), 1) & "," & Mid(y, i, 1) 'Like  "T5689,3,7"，第一位为相似数，第二位为第一个不同数，第三位为第二个不同数
    
43.     End If
    
44. End Function
    
45. 
    
46. Function ISGN(p, y) As Boolean     '归纳数p是否区配原数y，并返回y中该去掉的数
    
47.     xs = "": d.RemoveAll
    
48.     d(p) = ""
    
49.     For i = 2 To Len(y)
    
50.         p = Left(y, i - 1) & Mid(y, i + 1)
    
51.         If d.exists(p) Then ISGN = True: Exit For
    
52.     Next
    
53.     If ISGN Then xs = Mid(y, i, 1)
    
54. End Function
    

复制代码