[已解决]求提速!!!

香川群子

待匹配检查数据、默认为由英文大写字符和0-9一共36个字符组成的6位数。

检查任意位置有5个字符相同时、判断为匹配成功，提取共同字符并列出差异字符。
但每行仅保留第一次匹配结果。

grf1973

不用字典的确提高一些。

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

复制代码

随机取的数值，大多匹配度不高，2000条在7秒左右。如果匹配度高的话速度可以提高很多。

zhouxingyu

先谢过各位大神,备感荣辛.

zhouxingyu

香川群子 发表于 2016-4-22 13:37
楼主问题需要明确规则。

比如，T56789 既和前面的 T35689 有相同的5个=T5689，

H列每个值包含字母T共6位,除掉字母T有5位数值,其中4位数值有相同,1位数值不同.
遍历H列进行匹配.

zhouxingyu

香川群子 发表于 2016-4-22 14:19
楼主如果对几万行数据进行双重循环检查，那么耗时是指数增加的，吃不消。

因此，最重要的问题：

首位字母都是T,确实可以忽略.

zhouxingyu

上清宫主 发表于 2016-4-22 14:52
好象……我的代码就是这个思路。只是没去多伤脑细胞，致使细节上还有很多优化的地方
万来个数据不到1秒 ...

你的代码速度是可以接受的,30000多条数据耗时18秒左右.
只是计算结果有的不正确.

zhouxingyu

香川群子 发表于 2016-4-22 15:08
如果原始数据大部分能被多次匹配，那么检查速度应该是很快的。
估计3万行也就十几分钟吧。

近6万行数据如果能够在半小时以内是可以接受的.

zhouxingyu

grf1973 发表于 2016-4-22 15:10

本尊现身,有劳你了.
你的代码已经达到规则要求了,只是再优化提下速就完美了.

zhouxingyu

万分感谢以上各位大神.收下测试,慢慢消化.

grf1973

建议你把数据发上来试试。