xiaomage1的求助：万千百十个组合分析

香川群子

有个新手，ID：xiaomage1

在我的帖子里提了问题。
我做了解答，可是后来他又有问题了……

于是，我建议他要新开帖子讨论。

他可能用手机不方便，我就来开帖了。

……………………………………

以下是问题：
万千百十个共5个数位，其中3个数位有0-9的数值，另外2个数位是空的，这样3个数值2个空就成为1种组合。
如： 123__,1_2_3,__123这样的。（其中_下划线表示该数位没有数值。）

现在xiaomage1有很多这样的不同数位3个数的组合，
这些组合中有些正好能符合凑成一个完整5位数，即：
123__
_235_
__356
这样几个组合，就可以凑成一个12356的五位数。

即，这个五位数的任取3个数位的组合结果，都在原始数据中存在。



他想知道，符合条件的五位数一共有多少。

附件是xiaomage1第一次提问时的附件。

香川群子

经过原理分析，我做了解答。

编写的代码，虽然不算太复杂，但是也很繁琐。
见链接16楼
http://club.excelhome.net/thread-742341-2-1.html


废了不少力气，把小马哥1的【万千百十个】五位数字组合分析程序编写完成了。

考虑到程序接口方便，我把数据形式又改了。
现在是改成，各种数字直接按ABCDE，即【万千百十个】方式拆开填入相应列。

这样计算就很方便了。

香川群子

这个组合分析的要点，是对各种类型的组合不要产生遗漏。

主要思路如下：
每一组数值，如ABC，首先要检查它们和其它数字组合中，
要求其中有2个是相同的，然后才能符合条件，让新元素加入。

那么，假设对于ABC，则它任取2个以后的组合形式一共有3种：
1. A - BC
2. B - AC
3. C - AB

接着，依次检查所有数据中，符合有2个值相同的组合，即：
1. A - BC  →  检查 BC-D 或 BC-E
2. B - AC  →  检查 AC-D 或 AC-E
3. C - AB  →  检查 AB-D 或 AB-E

然后，对于这新的6种组合，都要再次进行检查：
举例，如对于A-BC-D 组合，且符合BC相同时，可以确定D值有效，
接下来，对于BCD这3个值的任意取2数进行组合检查，则有：
1. B -CD  →  CD-E  (即找到有CD也符合相同时，可最终确定 E值)
2. C -BD  →  BD-E  (即找到有BD也符合相同时，可最终确定 E值)
3. D -BC  →  BC-E  (即找到有BC也符合相同时，可最终确定 E值)

………………

这样，把第一步得到的前面6种组合，即：
1. A - BC  →  检查 BC-D 或 BC-E
2. B - AC  →  检查 AC-D 或 AC-E
3. C - AB  →  检查 AB-D 或 AB-E

其中每一个组合再产生3种可能的组合进行检查，就能得到所有的符合条件的组合结果了。

…………

总之，对于m个原始3位数的值，
都要检查 6*3*m=18*m 种组合。




为了高效计算，我在sheet2中做了辅助参数表，并使用了字典定位方式。
当数据量不大时，计算速度倒还比较快。

香川群子

后来，楼主又提出了进一步的要求，得到的五位数，必须符合任意位置的10种组合都要有，缺一不可。


于是，我把提取到的结果，再次和原始数据比对，最后就得到了正确的结果。

香川群子

但是，当楼主再次提供7842行数据要求分析时，
发现原来的程序，因为需要反复循环计算，耗时太多了，每一行数据的完全循环比对，就要将近1分钟。

那7842行数据，将耗时17个小时。


这样的程序，是失败了。

香川群子

于是我想了又想，发现一个捷径：

我根本不需要对原始数据进行组合来产生有效的五位数，
那样做计算量太大。

我仅仅需要，模拟生成所有的五位数，（即0-99999）
然后和原始数据比对，检查是否这个五位数的10种位数组合都存在于原始数据中，就行了。


…………
想到这些以后，我马上去写代码，代码写完，运行……结果10多秒就能比对计算完成了……

真是，踏破铁鞋无觅处，得来全不费功夫。
【代码再多无用处，算法对路不费力】

香川群子

很意外地是，生成0-99999五位数，并拆分成万、千、百、十、个位五个数值时，
以下代码的写法居然相差很大。

1. Sub SpeedCompare()
   
2.     Dim i&, m%
   
3.     m = 1 '此处m是设置运行次数。10的m次幂次。
   
4.     '如果程序单次运行时间很短，可以设置m值=3 即运行1000次，
   
5.    '甚至可设置m=6，即运行1百万次。
   
6.    '如果程序单次运行时间已经较长，则设置m=0，只运行10的0次方=1次。
   
7.    
   
8.     tms = Timer
   
9.     For i = 1 To 10 ^ m
   
10.         Call get1
    
11.     Next
    
12.     MsgBox Format(Timer - tms, "0.0000s")
    
13.    
    
14.     tms = Timer
    
15.     For i = 1 To 10 ^ m
    
16.         Call get2
    
17.     Next
    
18.     MsgBox Format(Timer - tms, "0.0000s")
    
19.    
    
20. End Sub
    
21. 
    
22. Sub get1() '实际采用的算法，仅仅调整进位部分
    
23.     Dim i&, j%
    
24.     Dim a%(4)
    
25.     For i = 0 To 3
    
26.         a(i) = 0
    
27.     Next
    
28.     a(4) = -1
    
29.     For i = 0 To 99999
    
30.         For j = 4 To 0 Step -1
    
31.             If a(j) < 9 Then
    
32.                 a(j) = a(j) + 1: Exit For
    
33.             Else
    
34.                 a(j) = 0
    
35.             End If
    
36.         Next
    
37.     Next
    
38. End Sub
    
39. 
    
40. Sub get2() '传统算法思路，用right整形以后，用mid拆分
    
41.     Dim i&, j%, s$
    
42.     Dim a%(4)
    
43.     For i = 0 To 99999
    
44.         s = Right("0000" & i, 5)
    
45.         For j = 0 To 4
    
46.             a(j) = Mid(s, j + 1, 1)
    
47.         Next
    
48.     Next
    
49. End Sub

复制代码

香川群子

最终解决问题的代码如下：

1. Sub test2()
   
2.     tms = Timer
   
3.    
   
4.     Dim i&, j%, k%, l&
   
5.     Sheets(1).[f2].Resize(65535, 5) = ""
   
6.    
   
7.     arr = Sheets(1).[a1].CurrentRegion
   
8.     Set d = CreateObject("Scripting.Dictionary")
   
9.     s = Array("万", "千", "百", "十", "个")
   
10.     For i = 2 To UBound(arr)
    
11.         arr(i, 6) = ""
    
12.         arr(i, 7) = ""
    
13.         arr(i, 8) = ""
    
14.         For j = 1 To 5
    
15.             If arr(i, j) = "" Then
    
16.                 arr(i, 8) = arr(i, 8) & "_"
    
17.             Else
    
18.                 arr(i, 6) = arr(i, 6) & Chr(64 + j)
    
19.                 arr(i, 7) = arr(i, 7) & s(j - 1)
    
20.                 arr(i, 8) = arr(i, 8) & arr(i, j)
    
21.             End If
    
22.         Next
    
23.         d(arr(i, 8)) = 1
    
24.     Next
    
25.     Sheets(1).[a1].CurrentRegion = arr
    
26.    
    
27. '    MsgBox Timer - tms
    
28. '    tms = Timer
    
29.    
    
30.     Dim a%(4)
    
31.     Dim b(65535, 0)
    
32.     Dim c(9)
    
33.    
    
34.     For j = 0 To 4
    
35.         a(j) = 0
    
36.     Next
    
37.     a(4) = -1
    
38.     For i = 0 To 99999
    
39.         For j = 4 To 0 Step -1
    
40.             If a(j) < 9 Then
    
41.                 a(j) = a(j) + 1: Exit For
    
42.             Else
    
43.                 a(j) = 0
    
44.             End If
    
45.         Next
    
46.         c(0) = a(0) & a(1) & a(2) & "__"
    
47.         c(1) = a(0) & a(1) & "_" & a(3) & "_"
    
48.         c(2) = a(0) & a(1) & "__" & a(4)
    
49.         c(3) = a(0) & "_" & a(2) & a(3) & "_"
    
50.         c(4) = a(0) & "_" & a(2) & "_" & a(4)
    
51.         c(5) = a(0) & "__" & a(3) & a(4)
    
52.         c(6) = "_" & a(1) & a(2) & a(3) & "_"
    
53.         c(7) = "_" & a(1) & a(2) & "_" & a(4)
    
54.         c(8) = "_" & a(1) & "_" & a(3) & a(4)
    
55.         c(9) = "__" & a(2) & a(3) & a(4)
    
56.         
    
57.         k = 0
    
58.         For j = 0 To 9
    
59.             k = k + d(c(j))
    
60.         Next
    
61.         If k = 10 Then
    
62.             b(l, 0) = "'" & Right("0000" & i, 5): l = l + 1
    
63.         End If
    
64.     Next
    
65.     Sheets(1).[j2].Resize(l) = b
    
66.    
    
67.     MsgBox Timer - tms
    
68.    
    
69. End Sub

复制代码

xiaomage1

香川群子 发表于 2012-4-3 19:12
最终解决问题的代码如下：

群子老师，谢谢您

longming3

高，确实是高，想穿裙子老师厉害啊，这股钻劲让人佩服。