[已解决]求提速!!!

zhouxingyu

香川群子 发表于 2016-4-23 12:27
按你的提取5个组合存入字典的思路，我也重新写了个代码。

仅使用1个字典，作为组合序号。其它全用数组 ...

神奇的速度.你要成速度女神了!

grf1973

香川群子 发表于 2016-4-23 12:27
按你的提取5个组合存入字典的思路，我也重新写了个代码。

仅使用1个字典，作为组合序号。其它全用数组 ...

干脆不用字典。不过速度未有明显提高。

1. Sub test3() '
   
2.     Dim arr, ar1() As Boolean, ar2(), br(0 To 9999, 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.     For i = 1 To m '遍历数据各行
    
11.         s = arr(i, 1) '读取后5位字符
    
12.         For j = 1 To 5 '产生5种5位组合(按排列顺序区分不考虑合并相同组合 即 1234 和 4321 算不同的结果)
    
13.             n = Mid(s, 2, j - 1) & Mid(s, j + 2) '拼接为4位组合t
    
14.             br(n, 3) = br(n, 3) + 1   '直接用4位组合数做为br的序号
    
15.             br(n, 1) = br(n, 1) & "," & i: br(n, 2) = br(n, 2) & "," & j
    
16.             '在序号n对应数组br中存入行信息 i 、以及提取差异字符位置 j
    
17.         Next
    
18.     Next
    
19.    
    
20.     For n = 0 To 9999 '遍历所有可能的4位数
    
21.         If br(n, 3) > 1 Then        '里面有组合数超过2个的
    
22.             sr1 = Split(br(n, 1), ",") '拆分还原为i的数组sr1
    
23.             sr2 = Split(br(n, 2), ",") '拆分还原为j的数组sr2
    
24.             For j = 1 To UBound(sr1) '遍历该字典中字符组合t对应的行
    
25.                 i = sr1(j) '还原行i
    
26.                 If Not ar1(i) Then '如尚未有匹配标记
    
27.                     ar1(i) = True '标记为已匹配
    
28.                     ar2(i, 1) = "T" & Format(n, "0000") '组合结果写入第1列
    
29.                     ar2(i, 2) = Mid(arr(i, 1), sr2(j) + 1, 1) '差异字符写入第2列
    
30.                 End If
    
31.             Next
    
32.         End If
    
33.     Next
    
34.    
    
35.     MsgBox Format(Timer - tms, "0.000s ") & k & "/" & m '计算耗时/字典得到组合个数k/检查数据行数m
    
36.     Range("M2").Resize(m, 2) = "" '清空输出区域
    
37.     Range("M2").Resize(m, 2) = ar2 '结果写入工作表
    
38. End Sub

复制代码

zhouxingyu

grf1973 发表于 2016-4-23 21:29
干脆不用字典。不过速度未有明显提高。

比39楼那个有大幅提高,还是很明显的.

香川群子

zhouxingyu 发表于 2016-4-23 23:20
比39楼那个有大幅提高,还是很明显的.

那是因为后面的部分用了我的算法。

香川群子

zhouxingyu 发表于 2016-4-23 23:20
比39楼那个有大幅提高,还是很明显的.

不用字典，速度应该更快一些……因为字典的速度效率没有纯数组高

1. Sub test3() 'by kagawa 2016/4/24
   
2.     Dim arr, ar1() As Boolean, ar2(), br(1 To 10000, 1 To 3), dr&(9999), 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.     For i = 1 To m '遍历数据各行
    
11. '        s = px(arr(i, 1)): arr(i, 1) = s '读取6位字符
    
12.         s = arr(i, 1)
    
13.         For j = 0 To 4 '产生5种5位组合(按排列顺序区分不考虑合并相同组合 即 1234 和 4321 算不同的结果)
    
14.             t = Mid(s, 2, j) & Mid(s, j + 3) '拼接为4位数字的组合t
    
15.             n = dr(t): If n = 0 Then k = k + 1: dr(t) = k: n = k: br(n, 3) = Left(s, 1) & t
    
16.             '读取数组dr组合t对应序号的顺序n、如序号不存在则新增序号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) + 2, 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

复制代码

zhouxingyu

香川群子 发表于 2016-4-24 13:45
不用字典，速度应该更快一些……因为字典的速度效率没有纯数组高

准确性如何?你有没有发现:72楼的代码计算出来的匹配结果没有包括0.数量从1-9递增,9是最多的.

香川群子

zhouxingyu 发表于 2016-4-24 14:21
准确性如何?你有没有发现:72楼的代码计算出来的匹配结果没有包括0.数量从1-9递增,9是最多的.

72楼代码不是我写的。

我自己的两个代码，用随机生成的数据来测试，是0-9都有出现的。


…………
对72楼 grf1973的代码研究发现，因为遍历原始数据得到的结果直接存入了0-9999对应的数组，
而整理输出检查结果时，未按照原来的先后顺序，而是按照0000-9999的组合顺序了……

因此，将优先匹配0000开始的组合，而不论实际找到匹配行的先后顺序。
结果就是，0不能匹配的概率大大降低。其次是1、2……而9不能匹配的概率最高。

呵呵。以下是统计结果：

0	3
1	434
2	966
3	1660
4	2381
5	3394
6	4387
7	5767
8	7256
9	8752

而我的代码，仍然忠实于原始检查顺序，所以结果0-9的分布很正常。

0	3581
1	3457
2	3644
3	3647
4	4213
5	3478
6	3332
7	2924
8	3630
9	3094

zhouxingyu

香川群子 发表于 2016-4-24 17:22
72楼代码不是我写的。

我自己的两个代码，用随机生成的数据来测试，是0-9都有出现的。

我开个新贴,你把75楼的代码传上去.付出辛劳写的代码该评个最佳.
如何?

香川群子

zhouxingyu 发表于 2016-4-24 17:33
我开个新贴,你把75楼的代码传上去.付出辛劳写的代码该评个最佳.
如何?

不用了……我不看重这个虚名的。

我是大师级别的，不用别人捧场。

zhouxingyu

香川群子 发表于 2016-4-24 17:45
不用了……我不看重这个虚名的。

我是大师级别的，不用别人捧场。

我清楚你是什么级别.麻烦了你这么久,挺不好意思的.