史上最酷的Excel VBA 组合算法 代码

zhu918918

香川群子 发表于 2014-5-22 09:31
代码如附件。

附件为2003版，可自行转为2007版后使用。

谢谢香川群子老师！可能是我说错了。应该是不重复的排列，结果应该是48598个，一列可以排完的（我用的是2007版）。老师，按结果48598个如果是排列，怎么写代码？感谢您了！！！
另外，如果结果多于1048575时，超出部分写在aq2:av列，结果不应该多于2列的（最多为1344904个）
谢谢香川群子老师！！！

香川群子

zhu918918 发表于 2014-5-22 16:38
谢谢香川群子老师！可能是我说错了。应该是不重复的排列，结果应该是48598个，一列可以排完的（我用的是2 ...

去除重复……

疑问.1
那每一个组合中的数字能重复出现吗？
例如：4,4,4,7,7,31 算不算有效组合？

疑问.2
那同时还要求组合必须是从小到大排序吧？
例如： 18,16,17,15,14,31 算不算有效组合？

香川群子

按照从小到大，排除不重复组合时的代码及附件：

1. Dim sj&(), jg&(), m&, n&, k&, t&, cnt&, cnt2&
   
2. Sub MultiColumnCombin() 'by kagawa
   
3.     tms = Timer
   
4.     [ai1].CurrentRegion = ""
   
5.     sj0 = [aa1].CurrentRegion.Offset(1, 1)
   
6.     '以AA1列中序号的行数决定原始数据区域大小。所以序号不能错！
   
7.    
   
8.     m = UBound(sj0) - 1: n = UBound(sj0, 2) - 1
   
9.     ReDim sj&(1 To m, 1 To n)
   
10.     For j = 1 To n
    
11.         k = 0
    
12.         For i = 1 To m
    
13.             If sj0(i, j) Then k = k + 1: sj(k, j) = sj0(i, j)
    
14.         Next
    
15.         If k > l Then l = k
    
16.     Next
    
17.     '以上把数据转为Long型数值 可以提高计算速度。
    
18.     m = l 'm更新为有效最大行数l 减少无效循环次数。
    
19.    
    
20.     cnt = InputBox("指定输出行数 cnt=", "", WorksheetFunction.Round(Cells.Rows.Count, -4))
    
21.     ReDim jg&(cnt, 1 To n)
    
22.     '指定输出行数 如2003 5万行 或2007时 100万行。
    
23.    
    
24.     k = 0: t = 0: cnt2 = 0: Call dgMN(1) '递归计算 并输出整数行的结果
    
25.     If k Then [aj1].Offset(1, (n + 1) * cnt2).Resize(k, n) = jg: [ai1].Offset(, (n + 1) * cnt2) = cnt2 + 1 '输出最后零数行的结果
    
26.     MsgBox Format(Timer - tms, "0.00s ") & Format(cnt * cnt2 + k, "#,##0")
    
27. End Sub
    
28. 
    
29. Sub dgMN(j&) '递归过程代码
    
30.     Dim l&
    
31.     For i = 1 To m '循环本列
    
32.         If sj(i, j) = 0 Then Exit For '本列为空时退出
    
33.         If sj(i, j) > t Then '确保大于上一列的值t 即可排除重复组合
    
34.             jg(k, j) = sj(i, j) '填入组合数据
    
35.             If j = n Then '已经到最后一列(=n)时
    
36.                 k = k + 1
    
37.                 For l = 1 To n - 1
    
38.                     jg(k, l) = jg(k - 1, l) '循环复制上一列数据
    
39.                 Next
    
40.                
    
41.                 If k = cnt Then '如果满足整数行则输出结果
    
42.                     [aj1].Offset(1, (n + 1) * cnt2).Resize(cnt, n) = jg
    
43.                     [ai1].Offset(, (n + 1) * cnt2) = cnt2 + 1: cnt2 = cnt2 + 1
    
44.                     For l = 1 To n - 1
    
45.                         jg(0, l) = jg(k, l) '循环复制上一列数据
    
46.                     Next
    
47.                     k = 0
    
48.                 End If
    
49.             Else
    
50.                 t = sj(i, j)
    
51.                 Call dgMN(j + 1) '递归到下一列
    
52.                 t = sj(i, j)
    
53.             End If
    
54.         End If
    
55.     Next
    
56. End Sub

复制代码

zhu918918

香川群子 发表于 2014-5-22 17:15
去除重复……

疑问.1

香川群子老师：例中2组合不是有效的。组合要求是从小到大无重复排列的数：1 2 3 4 5 6（最小组合），最大：29 30 31 32 33 34 。1 1 2 3 4 5，1 2 3 4 5 1，20 19 18 17 16 15等都无效。
谢谢香川群子老师！！！

zhu918918

香川群子 发表于 2014-5-22 21:59
按照从小到大，排除不重复组合时的代码及附件：

结果非常正确（已演算几个），速度非常惊人！！！香川群子老师，有其他方式联系吗（如qq)?因为问题多，电脑运行慢等诸不便原因，还望香川群子老师留个联系方式，多谢了，香川群子老师！！！

zhu918918

香川群子 发表于 2014-5-22 21:59
按照从小到大，排除不重复组合时的代码及附件：

老师，请问：如何把它装在一个按钮中？我装了几次没有成功。谢谢了！！！

frefs

写的不错！！！

no110119120

全都太厉害了

烽．火

留个记号。。有空来膜拜下

ak47ok

香川群子 发表于 2014-5-22 21:59
按照从小到大，排除不重复组合时的代码及附件：

见识了复川老师的神功，看看老师能否用VBA写出m因素n水平的所有排列组合

劳您费神了，感谢！！！