[已解决]求提速!!!

爱疯

3行数据.rar (6.56 KB, 下载次数: 4)

2016-4-22 23:28 上传

点击文件名下载附件

楼主手动做出结果，再把这个3行数据的附件，传上来看看？

zhouxingyu

爱疯 发表于 2016-4-22 23:29
楼主手动做出结果，再把这个3行数据的附件，传上来看看？

第三行与第二行有重叠.
3行数据手动结果.zip (7.73 KB, 下载次数: 3)

2016-4-22 23:48 上传

点击文件名下载附件

爱疯

和T56789重叠，是啥意思？

grf1973

爱疯 发表于 2016-4-23 09:42
和T56789重叠，是啥意思？

提取相同数值.zip (16.34 KB, 下载次数: 11)

2016-4-23 11:06 上传

点击文件名下载附件
加了文字说明。

zhouxingyu

爱疯 发表于 2016-4-23 09:42
和T56789重叠，是啥意思？

第二行那个T56789既能和第一行的T35689包含(T5689相同),又能和第三行T25679包含(T5679相同)

zhouxingyu

grf1973 发表于 2016-4-23 11:06
加了文字说明。

还是大神表述的清晰又直观.

香川群子

grf1973 发表于 2016-4-22 21:53
我的思路
1、遍历原数据，每个数x最多有五种不同的归纳形式p
2、用字典把每个p和行数联系起来

按你的提取5个组合存入字典的思路，我也重新写了个代码。

仅使用1个字典，作为组合序号。其它全用数组进行，
因此比你的算法快5-6倍。

1. Sub test2() 'by kagawa 2016/4/23
   
2.     Dim arr, ar1() As Boolean, ar2(), br(1 To 10000, 1 To 3), dic, sr1, sr2
   
3.     Dim i&, j&, k&, m&, n&, s$, t$, tms#
   
4.    
   
5.     tms = Timer
   
6. '    m = Range("A1").End(4).Row - 1: arr = Range("A2").Resize(m) '读取A列原始数据
   
7.     m = Range("H1").End(4).Row - 1: arr = Range("H2").Resize(m) '或读取H列原始数据
   
8.     ReDim ar1(1 To m), ar2(1 To m, 1 To 2) 'ar1标记已匹配、ar2存放匹配结果
   
9.    
   
10.     Set dic = CreateObject("scripting.dictionary") '字典仅用于记录5位组合的序号
    
11.     For i = 1 To m '遍历数据各行
    
12.         s = arr(i, 1) '读取6位字符
    
13.         For j = 1 To 5 '产生5种5位组合(按排列顺序区分不考虑合并相同组合 即 1234 和 4321 算不同的结果)
    
14.             t = Left(s, j) & Mid(s, j + 2) '拼接为5位组合t
    
15.             n = dic(t): If n = 0 Then k = k + 1: dic(t) = k: n = k: br(n, 3) = t
    
16.             '读取字典中组合t对应序号n、如字典不存在t则新增序号n=k+1
    
17.             br(n, 1) = br(n, 1) & "," & i: br(n, 2) = br(n, 2) & "," & j
    
18.             '在序号n对应数组br中存入行信息 i 、以及提取差异字符位置 j
    
19.         Next
    
20.     Next
    
21.    
    
22.     For n = 1 To k '遍历k个字典结果 (算排列至多1万种、算排序后组合则只有715种)
    
23.         sr1 = Split(br(n, 1), ",") '拆分还原为i的数组sr1
    
24.         sr2 = Split(br(n, 2), ",") '拆分还原为j的数组sr2
    
25.         If UBound(sr1) > 1 Then '如没有匹配到其它行则略过本组合
    
26.             For j = 1 To UBound(sr1) '遍历该字典中字符组合t对应的行
    
27.                 i = sr1(j) '还原行i
    
28.                 If Not ar1(i) Then '如尚未有匹配标记
    
29.                     ar1(i) = True '标记为已匹配
    
30.                     ar2(i, 1) = br(n, 3) '组合结果写入第1列
    
31.                     ar2(i, 2) = Mid(arr(i, 1), sr2(j) + 1, 1) '差异字符写入第2列
    
32.                 End If
    
33.             Next
    
34.         End If
    
35.     Next
    
36.    
    
37.     MsgBox Format(Timer - tms, "0.000s ") & k & "/" & m '计算耗时/字典得到组合个数k/检查数据行数m
    
38.     Range("I2").Resize(m, 2) = "" '清空输出区域
    
39.     Range("I2").Resize(m, 2) = ar2 '结果写入工作表
    
40. End Sub

复制代码

香川群子

楼上代码有一个bug已更新:

If UBound(sr1) > 1 Then '如没有匹配到其它行则略过本组合

否则会自动提取第1个组合作为匹配结果，导致错误。

香川群子

5位数字从00000-99999是10万个，但其中任取4位的组合相当于0000-9999最多只有1万个.

但如果5位数字已经从小到大排序，则00000-99999只有2002个，而4位组合0000-9999中不同组合只有715个。

排序代码如下：

1. Function px$(s)
   
2.     Dim a(0 To 9), i&, t$
   
3.     For i = 2 To 6
   
4.         t = Mid(s, i, 1): a(t) = a(t) & t
   
5.     Next
   
6.     px = Left(s, 1) & Join(a, "")
   
7. End Function
   

复制代码

仅需把原先代码中：
s = arr(i, 1) '读取6位字符

改为：
s = px(arr(i, 1)): arr(i, 1) = s '读取排序后的6位字符、并更新

计算耗时有增加，但不同的4位组合总数仅715个，匹配成功率更高了。

zhouxingyu

香川群子 发表于 2016-4-23 13:01
5位数字从00000-99999是10万个，但其中任取4位的组合相当于0000-9999最多只有1万个.

但如果5位数字已经从 ...

真是发挥到极致了.辛苦你了!