比组合算法更难的【排列算法生成器】代码

香川群子

组合算法用多层循环做思路很简单，只要每一层的计数变量起始值比上一层+1就可以保证不重复取值。

但是，排列就不同，难度要增加很多……每一个位置都要从1开始循环，但必须排除前面已经出现的重复值。


因此，每一层循环的去重复，就成为排列循环算法的关键。

大致有下面几种：
1. 最简单的If <> 判断
For i1 = 1 To m
  For i2 = 1 To m  
    If i2<>i1 Then
       For i3 = 1 To m
         If i3<>i2 And i3 <> i1 Then

这样逻辑简单，但采用多条件同时判断的算法，执行起来效率很低。
而且If 判断语句到后面会越来越长。

2. Instr判断

For i1 = 1 To m
    s1 = "," & i1
    For i2 = 1 To m
      If InStr(s1 & ",", "," & i2 & ",") = 0 Then
        s2 = s1 & "," & i2
        For i3 = 1 To m
          If InStr(s2 & ",", "," & i3 & ",") = 0 Then
  
即，每一层都把新取值的序号位置加入判断字符串s，
然后进入下一层循环时，Instr函数只要用一次就能判断当前取值序号是否重复。

这样计算效率是高了，但毕竟前期字符串的准备也很麻烦、执行效率仍然较低。

3. 用数组存储记录位置是否已经占用
  ReDim a&(1 To m) '先定义一个数组a用来存放m个元素的占用状态
  For i1 = 1 To m
    a(i1) = 3 '记录被占用
    For i2 = 1 To m
      If a(i2) = 0 Then '判断未被占用
        a(i2) = 2 '记录被占用
        For i3 = 1 To m
          If a(i3) = 0 Then '判断未被占用
  
…………这样使用数组以后，速度效率有很大提高。
总结：【在VBA中尽量使用数组来计算是效率最高的算法】

下面是【多层循环数组记录去重复】的【排列算法生成器】代码：

1. Sub 生成排列代码()
   
2.    
   
3.     n = Val(InputBox("抽取个数 n =", "生成排列代码", [b1]))
   
4.     If n = 0 Then Exit Sub Else [b1] = n
   
5.     m = Val(InputBox("排列对象个数 m =", "生成排列代码", [a1].End(4).Row))
   
6.     If m >= n Then k = WorksheetFunction.Permut(m, n): MsgBox "排列结果总数 = " & k
   
7.    
   
8. '    TmN = "AutoPermut_Arr_" & Format(Date, "yymmdd_") & Format(Time, "hhmm_") & "Macro"
   
9.     tmN = "AutoPermut_" & n & "_ArrMacro"
   
10.     s = s & "Sub " & tmN & "()" & Chr(10) & Chr(10)
    
11.     s = s & "  Dim k&, m&, n&, tms#" & Chr(10)
    
12.     s = s & "  tms = Timer" & Chr(10)
    
13.     s = s & "  n = " & n & ": m = [a1].End(4).Row: If m < n Then Exit Sub" & Chr(10)
    
14.     s = s & "  k = WorksheetFunction.Permut(m, n)" & Chr(10)
    
15.     s = s & "  If k < Cells.Rows.Count Then ReDim jg(1 To k, 0 To n)" & Chr(10)
    
16.     s = s & "  k = 0 : sj = [a1].Resize(m)" & Chr(10) & Chr(10)
    
17.    
    
18.     s = s & "  ReDim a&(1 To m)" & Chr(10)
    
19.    
    
20.     t1 = "  Dim i1&"
    
21.     For i = 1 To n - 1
    
22.         t1 = t1 & ", i" & i + 1 & "&"
    
23.     Next
    
24.     s = s & t1 & Chr(10)
    
25.    
    
26.     s = s & "  For i1 = 1 To m" & Chr(10)
    
27.    
    
28.     t2 = String(n * 4, " ") & "jg(k, 0) = i1"
    
29.     t3 = "'" & String(n * 4, " ") & "jg(k, 1) = i1"
    
30.     t4 = "'" & String(n * 4, " ") & "jg(k, 0) = sj(i1, 1)"
    
31.     t5 = String(n * 4, " ") & "jg(k, 1) = sj(i1, 1)"
    
32.       
    
33.     For i = 1 To n - 1
    
34.         s = s & String(i * 4, " ") & "a(i" & i & ") = " & n - i + 1 & Chr(10)
    
35.         s = s & String(i * 4, " ") & "For i" & i + 1 & " = 1 To m" & Chr(10)
    
36.         s = s & String(i * 4, " ") & "  If a(i" & i + 1 & ") = 0 Then" & Chr(10)
    
37.         
    
38.         t2 = t2 & " & "","" & i" & i + 1
    
39.         t3 = t3 & " : jg(k, " & i + 1 & ") = i" & i + 1
    
40.         t4 = t4 & " & sj(i" & i + 1 & ", 1)"
    
41.         t5 = t5 & " : jg(k, " & i + 1 & ") = sj(i" & i + 1 & ", 1)"
    
42.     Next
    
43.    
    
44.     s = s & String(n * 4, " ") & "k = k + 1" & Chr(10)
    
45.     s = s & t2 & Chr(10)
    
46.     s = s & t3 & Chr(10)
    
47.     s = s & t4 & Chr(10)
    
48.     s = s & t5 & Chr(10)
    
49.    
    
50.     For i = n - 1 To 1 Step -1
    
51.         s = s & String(i * 4, " ") & "  End If" & Chr(10)
    
52.         s = s & String(i * 4, " ") & "Next" & Chr(10)
    
53.         s = s & String(i * 4, " ") & "a(i" & i & ") = 0" & Chr(10)
    
54.     Next
    
55.    
    
56.     s = s & "  Next" & Chr(10)
    
57.     s = s & "  If k > Cells.Rows.Count Then Msgbox Format(Timer - tms ,""0.000s "") & k : Exit Sub" & Chr(10) & Chr(10)
    
58.     s = s & "  [d1].CurrentRegion ="""": [d1].Resize(k, n + 1) = jg" & Chr(10)
    
59.     s = s & "  [d1].Resize(, n + 1).EntireColumn.AutoFit" & Chr(10)
    
60.     s = s & "  Msgbox Format(Timer - tms ,""0.000s "") & k" & Chr(10) & Chr(10)
    
61.     s = s & "End Sub"
    
62.    
    
63.     key = MsgBox("马上实行排列宏吗", vbDefaultButton2 + vbYesNo)
    
64.     If key = vbYes Then
    
65.         Set t = ThisWorkbook.VBProject.VBComponents.Add(1)
    
66.         t.CodeModule.AddFromString s
    
67.         Application.Run "" & tmN
    
68.         ThisWorkbook.VBProject.VBComponents.Remove t
    
69.     Else
    
70.         Set t = ActiveWorkbook.VBProject.VBComponents.Add(1)
    
71.         t.CodeModule.AddFromString s
    
72.         ActiveSheet.Buttons.Add(60, 30, 55, 30).Select
    
73.         With Selection
    
74.             .Characters.TEXT = "Permut_Arr" & Chr(10) & "n= " & n
    
75.             .AutoSize = True
    
76.             .Placement = xlFreeFloating
    
77.             .OnAction = ActiveWorkbook.Name & "!" & tmN
    
78.         End With
    
79.     '    ActiveWorkbook.VBProject.VBComponents.Remove t
    
80.     End If
    
81.    
    
82. End Sub
    

复制代码

香川群子

以此代码生成器，
要求n=5 即任取5个元素进行全排列得到的代码例子：

1. Sub AutoPermut_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.Permut(m, n)
   
7.   If k < Cells.Rows.Count Then ReDim jg(1 To k, 0 To n)
   
8.   k = 0:
   
9.   sj = [a1].Resize(m) '以A列元素为排列对象 如 A1="A",A2="B",A3="C",A4="D",A5="E",……
   
10. 
    
11.   ReDim a&(1 To m)
    
12.   Dim i1&, i2&, i3&, i4&, i5&
    
13.   For i1 = 1 To m
    
14.     a(i1) = 5
    
15.     For i2 = 1 To m
    
16.       If a(i2) = 0 Then
    
17.         a(i2) = 4
    
18.         For i3 = 1 To m
    
19.           If a(i3) = 0 Then
    
20.             a(i3) = 3
    
21.             For i4 = 1 To m
    
22.               If a(i4) = 0 Then
    
23.                 a(i4) = 2
    
24.                 For i5 = 1 To m
    
25.                   If a(i5) = 0 Then
    
26.                     k = k + 1
    
27. '                    jg(k, 0) = i1 & "," & i2 & "," & i3 & "," & i4 & "," & i5
    
28. '                    jg(k, 1) = i1 : jg(k, 2) = i2 : jg(k, 3) = i3 : jg(k, 4) = i4 : jg(k, 5) = i5
    
29.                     jg(k, 0) = sj(i1, 1) & sj(i2, 1) & sj(i3, 1) & sj(i4, 1) & sj(i5, 1)
    
30.                     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)
    
31.                   End If
    
32.                 Next
    
33.                 a(i4) = 0
    
34.               End If
    
35.             Next
    
36.             a(i3) = 0
    
37.           End If
    
38.         Next
    
39.         a(i2) = 0
    
40.       End If
    
41.     Next
    
42.     a(i1) = 0
    
43.   Next
    
44.   If k > Cells.Rows.Count Then MsgBox Format(Timer - tms, "0.000s ") & k: Exit Sub
    
45. 
    
46.   [d1].CurrentRegion = "": [d1].Resize(k, n + 1) = jg
    
47.   [d1].Resize(, n + 1).EntireColumn.AutoFit
    
48.   MsgBox Format(Timer - tms, "0.000s ") & k
    
49. 
    
50. End Sub

复制代码

香川群子

输出结果一共有4个语句，分别是：

jg(k, 0) = i1 & "," & i2 & "," & i3 & "," & i4 & "," & i5
在第0列 输出合并的组合序号(以逗号分隔)，如： 1,2,3,4,5 或 5,4,3,2,1

jg(k, 0) = sj(i1, 1) & sj(i2, 1) & sj(i3, 1) & sj(i4, 1) & sj(i5, 1)
在第0列 输出合并的组合结果(无分隔)，如： ABCDE 或 EDCBA

jg(k, 1) = i1: jg(k, 2) = i2: jg(k, 3) = i3: jg(k, 4) = i4: jg(k, 5) = i5
在第1-n列 输出分开的各个组合序号如： 1   2   3   4   5

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)
在第1-n列 输出分开的各个元素如： A   B   C   D   E


上述输出结果，可以自行选择组合有效或无效(语句注释掉)

香川群子

我自己还研究了Replace置换后Mid取序号法，以及Filter法，但效率都不高。所以也就不特别介绍了。

1. Sub AutoPermut_3_MidRplMacro()
   
2. 
   
3. tms = Timer
   
4. Dim k&, m&, n&
   
5. n = 3: m = [a1].End(4).Row: If m < n Then Exit Sub
   
6. AP = WorksheetFunction.Permut(m, n)
   
7. ReDim jg(1 To AP, 0 To n)
   
8. sj = [a1].Resize(m)
   
9. 
   
10. Dim i1&, s1$, t1$, i2&, s2$, t2$, i3&, s3$, t3$
    
11. 
    
12. l = Len("" & m) + 1: t = "," & String(l - 2, "0")
    
13. For i1 = 1 To m
    
14.   s1 = s1 & Right(t & i1, l)
    
15. Next
    
16. 
    
17. For i1 = 0 To m - 1
    
18.   t1 = Right(t & i1 + 1, l - 1)
    
19.   s2 = Replace(s1, "," & t1, "")
    
20. For i2 = 0 To m - 2
    
21.   t2 = Mid(s2, i2 * l + 2, l - 1)
    
22.   s3 = Replace(s2, "," & t2, "")
    
23. For i3 = 0 To m - 3
    
24.   t3 = Mid(s3, i3 * l + 2, l - 1)
    
25.     k = k + 1
    
26.     jg(k, 0) = t1 & "," & t2 & "," & t3
    
27. '    jg(k, 1) = t1 : jg(k, 2) = t2 : jg(k, 3) = t3
    
28.     jg(k, 1) = sj(t1, 1): jg(k, 2) = sj(t2, 1): jg(k, 3) = sj(t3, 1)
    
29. Next i3, i2, i1
    
30. MsgBox k & vbCr & Format(Timer - tms, "0.000s")
    
31. 
    
32. End Sub
    

复制代码

算法原理是： 置换去掉当前已占用序号，然后Mid抽取剩余组合进行循环。

1. Sub AutoPermut_3_FilterMacro()
   
2. 
   
3. tms = Timer
   
4. Dim k&, m&, n&
   
5. n = 3: m = [a1].End(4).Row: If m < n Then Exit Sub
   
6. AP = WorksheetFunction.Permut(m, n)
   
7. ReDim jg(1 To AP, 0 To n)
   
8. sj = [a1].Resize(m)
   
9. 
   
10. Dim i1&, t1$, i2&, t2$, i3&, t3$
    
11. 
    
12. ReDim s0(m - 1)
    
13. For i1 = 1 To m
    
14.   s0(i1 - 1) = i1
    
15. Next
    
16. 
    
17. For i1 = 0 To m - 1
    
18.   t1 = s0(i1): s1 = s0: s1(i1) = "-"
    
19.   s1 = Filter(s1, "-", False)
    
20. For i2 = 0 To m - 2
    
21.   t2 = s1(i2): s2 = s1: s2(i2) = "-"
    
22.   s2 = Filter(s2, "-", False)
    
23. For i3 = 0 To m - 3
    
24.   t3 = s2(i3)
    
25.     k = k + 1
    
26.     jg(k, 0) = t1 & "," & t2 & "," & t3
    
27. '    jg(k, 1) = t1 : jg(k, 2) = t2 : jg(k, 3) = t3
    
28.     jg(k, 1) = sj(t1, 1): jg(k, 2) = sj(t2, 1): jg(k, 3) = sj(t3, 1)
    
29. Next i3, i2, i1
    
30. MsgBox k & vbCr & Format(Timer - tms, "0.000s")
    
31. 
    
32. End Sub
    

复制代码

每次用Filter法去除已占用序号，然后循环。

panzibao

看不懂什么东西

panzibao

求助高手，比如一排随机数字它们总和在700-705之间的排列，用过的数不算在同个排列里，这样的能不能做

张雄友

1楼的每行代码怎么都有 s = s & " ？顶一下。没有的话还会用，有就不会用了。

香川群子

张雄友 发表于 2014-5-15 21:11
1楼的每行代码怎么都有 s = s & " ？顶一下。没有的话还会用，有就不会用了。

代码看不懂不要紧。

复制、粘贴后，运行试一试就明白了。……是关于排列组合的代码。

香川群子

panzibao 发表于 2014-5-15 19:40
求助高手，比如一排随机数字它们总和在700-705之间的排列，用过的数不算在同个排列里，这样的能不能做

700-705之间，整数只有6个，但若算上小数，就是无穷个了。

……
你要生成几个随机数？小数点保留几位？

得到的小数允许重复吗？

它们的总和值有范围要求吗？


请上附件说明具体要求。

香川群子

panzibao 发表于 2014-5-15 19:31
看不懂什么东西

看不懂……会用宏吗？会复制、粘贴代码，然后运行吗？