五一以后最强帖【多层循环组合算法代码】生成器

香川群子

需要列出全部组合结果时，最快的还是简单有效的多层循环。

但是有一个问题，如果每次要求组合提取数n不同，则循环层数不同，代码需要重新写……
而且如果n较大时，会很麻烦……


怎么解决这个问题呢？
一种思路，是直接编写通用算法的代码，用Do……Loop循环或递归算法，
一劳永逸地解决组合算法问题。（这个方面目前我香川群子的组合算法最好）

但是，这样的代码相对比较复杂一些，对于初学者来说不是很容易掌握。


因此，我给大家编写了【组合算法代码生成器】。
是那种最简单的多层循环组合算法。

代码如下：

1. Sub 生成多层循环组合代码()
   
2.    
   
3.     n = Val(InputBox("抽取个数 n =", "多层循环组合代码", [b1]))
   
4.     '输入n、或提取B1单元格中数字作为组合数n
   
5.     If n = 0 Then Exit Sub Else [b1] = n
   
6.     m = Val(InputBox("组合对象元素个数 m =", "多层循环组合代码", IIf([a2] = "", [a1], [a1].End(4).Row)))
   
7.     '输入m、或按A列元素个数m、或提取A1单元格中的数字作为组合元素总数m
   
8.     If m >= n Then k = WorksheetFunction.Combin(m, n): MsgBox "组合结果总数 = " & k
   
9.    
   
10.     tmN = "AutoCombin_Arr_" & n
    
11.     s = s & "Sub " & tmN & "()" & Chr(10) & Chr(10)
    
12.     s = s & "  Dim k&, m&, n&, tms#" & Chr(10)
    
13.     s = s & "  tms = Timer" & Chr(10)
    
14.     s = s & "  n = " & n & ": m = [a1].End(4).Row: If m < n Then Exit Sub" & Chr(10)
    
15.     s = s & "  k = WorksheetFunction.Combin(m, n)" & Chr(10)
    
16.     s = s & "  If k < Cells.Rows.Count Then ReDim jg(1 To k, 0 To n)" & Chr(10)
    
17.     s = s & "  k = 0 : sj = [a1].Resize(m)" & Chr(10) & Chr(10)
    
18.    
    
19.     t1 = "  Dim i1&"
    
20.     For i = 2 To n
    
21.         t1 = t1 & ", i" & i & "&"
    
22.     Next
    
23.     s = s & t1 & Chr(10)
    
24.    
    
25.     s = s & "  For i1 = 1 To m - " & n - 1 & Chr(10)
    
26.    
    
27.     t2 = "    jg(k, 0) = i1"
    
28.     t3 = "    jg(k, 1) = sj(i1, 1)"
    
29.     t4 = "'    jg(k, 0) = sj(i1, 1)"
    
30.     t5 = "'    jg(k, 1) = i1"
    
31.     t6 = "  Next i" & n
    
32.     For i = 2 To n
    
33.         s = s & "  For i" & i & " = i" & i - 1 & " + 1 To m - " & n - i & Chr(10)
    
34.         t2 = t2 & " & "","" & i" & i
    
35.         t3 = t3 & " : jg(k, " & i & ") = sj(i" & i & ", 1)"
    
36.         t4 = t4 & " & sj(i" & i & ", 1)"
    
37.         t5 = t5 & " : jg(k, " & i & ") = i" & i
    
38.         t6 = t6 & ", i" & n - i + 1
    
39.     Next
    
40. 
    
41.     s = s & "    k = k + 1" & Chr(10)
    
42.     s = s & IIf(k < Cells.Rows.Count, "", "'") & t2 & Chr(10)
    
43.     s = s & IIf(k < Cells.Rows.Count, "", "'") & t3 & Chr(10) & Chr(10)
    
44.     s = s & t4 & Chr(10)
    
45.     s = s & t5 & Chr(10)
    
46.     s = s & t6 & Chr(10)
    
47.    
    
48.     s = s & "  If k > Cells.Rows.Count Then Msgbox Format(Timer - tms ,""0.000s "") & k : Exit Sub" & Chr(10) & Chr(10)
    
49.     s = s & "  [d1].CurrentRegion ="""": [d1].Resize(k, n + 1) = jg" & Chr(10)
    
50.     s = s & "  [d1].Resize(, n + 1).EntireColumn.AutoFit" & Chr(10)
    
51.     s = s & "  Msgbox Format(Timer - tms ,""0.000s "") & k" & Chr(10) & Chr(10)
    
52.     s = s & "End Sub"
    
53.    
    
54.     key = MsgBox("立即运行这个组合计算宏吗", vbDefaultButton2 + vbYesNo)
    
55.     If key = vbYes Then
    
56.         Set t = ThisWorkbook.VBProject.VBComponents.Add(1)
    
57.         t.CodeModule.AddFromString s
    
58.         Application.run "" & tmN
    
59.         ThisWorkbook.VBProject.VBComponents.Remove t
    
60.     Else
    
61.         Set t = ActiveWorkbook.VBProject.VBComponents.Add(1)
    
62.         t.CodeModule.AddFromString s
    
63.         ActiveSheet.Buttons.Add(60, 30, 40, 30).Select
    
64.         With Selection
    
65.             .Characters.TEXT = "Combin_Arr" & Chr(10) & "n= " & n
    
66.             .AutoSize = True
    
67.             .Placement = xlFreeFloating
    
68.             .OnAction = ActiveWorkbook.Name & "!" & tmN
    
69.         End With
    
70.    
    
71.     '    ActiveWorkbook.VBProject.VBComponents.Remove t
    
72.     End If
    
73.    
    
74. End Sub

复制代码

请大家试用。有问题我会答疑。

香川群子

代码运用实例：

生成m选5的多层循环组合算法代码：
http://club.excelhome.net/forum. ... p;extra=#pid7618833

1. Sub AutoCombin_Arr_5()
   
2. 
   
3.   Dim k&, m&, n&, tms#
   
4.   tms = Timer
   
5.   n = 5: m = [a1].End(4).Row: If m < n Then Exit Sub
   
6.   k = WorksheetFunction.Combin(m, n)
   
7.   If k < Cells.Rows.Count Then ReDim jg(1 To k, 0 To n)
   
8.   k = 0: sj = [a1].Resize(m)
   
9. 
   
10.   Dim i1&, i2&, i3&, i4&, i5&
    
11.   For i1 = 1 To m - 4
    
12.   For i2 = i1 + 1 To m - 3
    
13.   For i3 = i2 + 1 To m - 2
    
14.   For i4 = i3 + 1 To m - 1
    
15.   For i5 = i4 + 1 To m - 0
    
16.     k = k + 1
    
17. '    jg(k, 0) = i1 & "," & i2 & "," & i3 & "," & i4 & "," & i5
    
18. '    jg(k, 1) = sj(i1, 1) : jg(k, 2) = sj(i2, 1) : jg(k, 3) = sj(i3, 1) : jg(k, 4) = sj(i4, 1) : jg(k, 5) = sj(i5, 1)
    
19. 
    
20. '    jg(k, 0) = sj(i1, 1) & sj(i2, 1) & sj(i3, 1) & sj(i4, 1) & sj(i5, 1)
    
21. '    jg(k, 1) = i1 : jg(k, 2) = i2 : jg(k, 3) = i3 : jg(k, 4) = i4 : jg(k, 5) = i5
    
22.   Next i5, i4, i3, i2, i1
    
23.   If k > Cells.Rows.Count Then MsgBox Format(Timer - tms, "0.000s ") & k: Exit Sub
    
24. 
    
25.   [d1].CurrentRegion = "": [d1].Resize(k, n + 1) = jg
    
26.   [d1].Resize(, n + 1).EntireColumn.AutoFit
    
27.   MsgBox Format(Timer - tms, "0.000s ") & k
    
28. 
    
29. End Sub

复制代码

香川群子

来一个m选32的多层循环组合算法代码：

1. Sub AutoCombin_Arr_32()
   
2. 
   
3.   Dim k&, m&, n&, tms#
   
4.   tms = Timer
   
5.   n = 32: m = [a1].End(4).Row: If m < n Then Exit Sub
   
6.   k = WorksheetFunction.Combin(m, n)
   
7.   If k < Cells.Rows.Count Then ReDim jg(1 To k, 0 To n)
   
8.   k = 0: sj = [a1].Resize(m)
   
9. 
   
10.   Dim i1&, i2&, i3&, i4&, i5&, i6&, i7&, i8&, i9&, i10&, i11&, i12&, i13&, i14&, i15&, i16&, i17&, i18&, i19&, i20&, i21&, i22&, i23&, i24&, i25&, i26&, i27&, i28&, i29&, i30&, i31&, i32&
    
11.   For i1 = 1 To m - 31
    
12.   For i2 = i1 + 1 To m - 30
    
13.   For i3 = i2 + 1 To m - 29
    
14.   For i4 = i3 + 1 To m - 28
    
15.   For i5 = i4 + 1 To m - 27
    
16.   For i6 = i5 + 1 To m - 26
    
17.   For i7 = i6 + 1 To m - 25
    
18.   For i8 = i7 + 1 To m - 24
    
19.   For i9 = i8 + 1 To m - 23
    
20.   For i10 = i9 + 1 To m - 22
    
21.   For i11 = i10 + 1 To m - 21
    
22.   For i12 = i11 + 1 To m - 20
    
23.   For i13 = i12 + 1 To m - 19
    
24.   For i14 = i13 + 1 To m - 18
    
25.   For i15 = i14 + 1 To m - 17
    
26.   For i16 = i15 + 1 To m - 16
    
27.   For i17 = i16 + 1 To m - 15
    
28.   For i18 = i17 + 1 To m - 14
    
29.   For i19 = i18 + 1 To m - 13
    
30.   For i20 = i19 + 1 To m - 12
    
31.   For i21 = i20 + 1 To m - 11
    
32.   For i22 = i21 + 1 To m - 10
    
33.   For i23 = i22 + 1 To m - 9
    
34.   For i24 = i23 + 1 To m - 8
    
35.   For i25 = i24 + 1 To m - 7
    
36.   For i26 = i25 + 1 To m - 6
    
37.   For i27 = i26 + 1 To m - 5
    
38.   For i28 = i27 + 1 To m - 4
    
39.   For i29 = i28 + 1 To m - 3
    
40.   For i30 = i29 + 1 To m - 2
    
41.   For i31 = i30 + 1 To m - 1
    
42.   For i32 = i31 + 1 To m - 0
    
43.     k = k + 1
    
44. '    jg(k, 0) = i1 & "," & i2 & "," & i3 & "," & i4 & "," & i5 & "," & i6 & "," & i7 & "," & i8 & "," & i9 & "," & i10 & "," & i11 & "," & i12 & "," & i13 & "," & i14 & "," & i15 & "," & i16 & "," & i17 & "," & i18 & "," & i19 & "," & i20 & "," & i21 & "," & i22 & "," & i23 & "," & i24 & "," & i25 & "," & i26 & "," & i27 & "," & i28 & "," & i29 & "," & i30 & "," & i31 & "," & i32
    
45. '    jg(k, 1) = sj(i1, 1) : jg(k, 2) = sj(i2, 1) : jg(k, 3) = sj(i3, 1) : jg(k, 4) = sj(i4, 1) : jg(k, 5) = sj(i5, 1) : jg(k, 6) = sj(i6, 1) : jg(k, 7) = sj(i7, 1) : jg(k, 8) = sj(i8, 1) : jg(k, 9) = sj(i9, 1) : jg(k, 10) = sj(i10, 1) : jg(k, 11) = sj(i11, 1) : jg(k, 12) = sj(i12, 1) : jg(k, 13) = sj(i13, 1) : jg(k, 14) = sj(i14, 1) : jg(k, 15) = sj(i15, 1) : jg(k, 16) = sj(i16, 1) : jg(k, 17) = sj(i17, 1) : jg(k, 18) = sj(i18, 1) : jg(k, 19) = sj(i19, 1) : jg(k, 20) = sj(i20, 1) : jg(k, 21) = sj(i21, 1) : jg(k, 22) = sj(i22, 1) : jg(k, 23) = sj(i23, 1) : jg(k, 24) = sj(i24, 1) : jg(k, 25) = sj(i25, 1) : jg(k, 26) = sj(i26, 1) : jg(k, 27) = sj(i27, 1) : jg(k, 28) = sj(i28, 1) : jg(k, 29) = sj(i29, 1) : jg(k, 30) = sj(i30, 1) : jg(k, 31) = sj(i31, 1) : jg(k, 32) = sj(i32, 1)
    
46. 
    
47. '    jg(k, 0) = sj(i1, 1) & sj(i2, 1) & sj(i3, 1) & sj(i4, 1) & sj(i5, 1) & sj(i6, 1) & sj(i7, 1) & sj(i8, 1) & sj(i9, 1) & sj(i10, 1) & sj(i11, 1) & sj(i12, 1) & sj(i13, 1) & sj(i14, 1) & sj(i15, 1) & sj(i16, 1) & sj(i17, 1) & sj(i18, 1) & sj(i19, 1) & sj(i20, 1) & sj(i21, 1) & sj(i22, 1) & sj(i23, 1) & sj(i24, 1) & sj(i25, 1) & sj(i26, 1) & sj(i27, 1) & sj(i28, 1) & sj(i29, 1) & sj(i30, 1) & sj(i31, 1) & sj(i32, 1)
    
48. '    jg(k, 1) = i1 : jg(k, 2) = i2 : jg(k, 3) = i3 : jg(k, 4) = i4 : jg(k, 5) = i5 : jg(k, 6) = i6 : jg(k, 7) = i7 : jg(k, 8) = i8 : jg(k, 9) = i9 : jg(k, 10) = i10 : jg(k, 11) = i11 : jg(k, 12) = i12 : jg(k, 13) = i13 : jg(k, 14) = i14 : jg(k, 15) = i15 : jg(k, 16) = i16 : jg(k, 17) = i17 : jg(k, 18) = i18 : jg(k, 19) = i19 : jg(k, 20) = i20 : jg(k, 21) = i21 : jg(k, 22) = i22 : jg(k, 23) = i23 : jg(k, 24) = i24 : jg(k, 25) = i25 : jg(k, 26) = i26 : jg(k, 27) = i27 : jg(k, 28) = i28 : jg(k, 29) = i29 : jg(k, 30) = i30 : jg(k, 31) = i31 : jg(k, 32) = i32
    
49.   Next i32, i31, i30, i29, i28, i27, i26, i25, i24, i23, i22, i21, i20, i19, i18, i17, i16, i15, i14, i13, i12, i11, i10, i9, i8, i7, i6, i5, i4, i3, i2, i1
    
50.   If k > Cells.Rows.Count Then MsgBox Format(Timer - tms, "0.000s ") & k: Exit Sub
    
51. 
    
52.   [d1].CurrentRegion = "": [d1].Resize(k, n + 1) = jg
    
53.   [d1].Resize(, n + 1).EntireColumn.AutoFit
    
54.   MsgBox Format(Timer - tms, "0.000s ") & k
    
55. 
    
56. End Sub
    

复制代码

如果这些代码自己写……可能会疯掉吧。而且容易出错。

abc3d

m = Val(InputBox("缁勫悎瀵硅薄鍏冪礌涓?暟 m =", "澶氬眰寰?幆缁勫悎浠ｇ爜", IIf([a2] = "", [a1], [a1].End(4).Row)))
    '杈撳叆m銆佹垨鎸堿鍒楀厓绱犱釜鏁癿銆佹垨鎻愬彇A1鍗曞厓鏍间腑鐨勬暟瀛椾綔涓虹粍鍚堝厓绱犳


请教代码粘贴后出现这种情况？

592rmb

香川老师是真正的大师，因为算法是解决问题的关键，老师一直在坚持提高算法的效率，学习

香川群子

abc3d 发表于 2014-5-6 13:29
m = Val(InputBox("缁勫悎瀵硅薄鍏冪礌涓?暟 m =", "澶氬眰寰?幆缁勫悎浠ｇ爜", IIf([a2] = "", [a1], [a ...

可能是我的字体有问题。

你自己把文字提示部分重新抄写一遍就可以了。

abc3d

香川群子 发表于 2014-5-6 14:41
可能是我的字体有问题。

你自己把文字提示部分重新抄写一遍就可以了。

谢谢！跟excel版本没关系吧，我用的是13版本的。

wqfzqgk

厉害，学习

oyzhjr

abc3d 发表于 2014-5-6 15:39
谢谢！跟excel版本没关系吧，我用的是13版本的。

你用32位的13版试试 ？我以前用64位的时候，VBA也是乱七八糟的问题。

CheryBTL

高大上呀，收藏学习！