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

香川群子 · 发表于 2014-5-15 08:36

组合算法用多层循环做思路很简单，只要每一层的计数变量起始值比上一层+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中尽量使用数组来计算是效率最高的算法】

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

Sub 生成排列代码()
n = Val(InputBox("抽取个数 n =", "生成排列代码", [b1]))
If n = 0 Then Exit Sub Else [b1] = n
m = Val(InputBox("排列对象个数 m =", "生成排列代码", [a1].End(4).Row))
If m >= n Then k = WorksheetFunction.Permut(m, n): MsgBox "排列结果总数 = " & k
' TmN = "AutoPermut_Arr_" & Format(Date, "yymmdd_") & Format(Time, "hhmm_") & "Macro"
tmN = "AutoPermut_" & n & "_ArrMacro"
s = s & "Sub " & tmN & "()" & Chr(10) & Chr(10)
s = s & " Dim k&, m&, n&, tms#" & Chr(10)
s = s & " tms = Timer" & Chr(10)
s = s & " n = " & n & ": m = [a1].End(4).Row: If m < n Then Exit Sub" & Chr(10)
s = s & " k = WorksheetFunction.Permut(m, n)" & Chr(10)
s = s & " If k < Cells.Rows.Count Then ReDim jg(1 To k, 0 To n)" & Chr(10)
s = s & " k = 0 : sj = [a1].Resize(m)" & Chr(10) & Chr(10)
s = s & " ReDim a&(1 To m)" & Chr(10)
t1 = " Dim i1&"
For i = 1 To n - 1
t1 = t1 & ", i" & i + 1 & "&"
Next
s = s & t1 & Chr(10)
s = s & " For i1 = 1 To m" & Chr(10)
t2 = String(n * 4, " ") & "jg(k, 0) = i1"
t3 = "'" & String(n * 4, " ") & "jg(k, 1) = i1"
t4 = "'" & String(n * 4, " ") & "jg(k, 0) = sj(i1, 1)"
t5 = String(n * 4, " ") & "jg(k, 1) = sj(i1, 1)"
For i = 1 To n - 1
s = s & String(i * 4, " ") & "a(i" & i & ") = " & n - i + 1 & Chr(10)
s = s & String(i * 4, " ") & "For i" & i + 1 & " = 1 To m" & Chr(10)
s = s & String(i * 4, " ") & " If a(i" & i + 1 & ") = 0 Then" & Chr(10)
t2 = t2 & " & "","" & i" & i + 1
t3 = t3 & " : jg(k, " & i + 1 & ") = i" & i + 1
t4 = t4 & " & sj(i" & i + 1 & ", 1)"
t5 = t5 & " : jg(k, " & i + 1 & ") = sj(i" & i + 1 & ", 1)"
Next
s = s & String(n * 4, " ") & "k = k + 1" & Chr(10)
s = s & t2 & Chr(10)
s = s & t3 & Chr(10)
s = s & t4 & Chr(10)
s = s & t5 & Chr(10)
For i = n - 1 To 1 Step -1
s = s & String(i * 4, " ") & " End If" & Chr(10)
s = s & String(i * 4, " ") & "Next" & Chr(10)
s = s & String(i * 4, " ") & "a(i" & i & ") = 0" & Chr(10)
Next
s = s & " Next" & Chr(10)
s = s & " If k > Cells.Rows.Count Then Msgbox Format(Timer - tms ,""0.000s "") & k : Exit Sub" & Chr(10) & Chr(10)
s = s & " [d1].CurrentRegion ="""": [d1].Resize(k, n + 1) = jg" & Chr(10)
s = s & " [d1].Resize(, n + 1).EntireColumn.AutoFit" & Chr(10)
s = s & " Msgbox Format(Timer - tms ,""0.000s "") & k" & Chr(10) & Chr(10)
s = s & "End Sub"
key = MsgBox("马上实行排列宏吗", vbDefaultButton2 + vbYesNo)
If key = vbYes Then
Set t = ThisWorkbook.VBProject.VBComponents.Add(1)
t.CodeModule.AddFromString s
Application.Run "" & tmN
ThisWorkbook.VBProject.VBComponents.Remove t
Else
Set t = ActiveWorkbook.VBProject.VBComponents.Add(1)
t.CodeModule.AddFromString s
ActiveSheet.Buttons.Add(60, 30, 55, 30).Select
With Selection
.Characters.TEXT = "Permut_Arr" & Chr(10) & "n= " & n
.AutoSize = True
.Placement = xlFreeFloating
.OnAction = ActiveWorkbook.Name & "!" & tmN
End With
' ActiveWorkbook.VBProject.VBComponents.Remove t
End If
End Sub

复制代码

香川群子 · 发表于 2014-5-15 08:41

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

Sub AutoPermut_Arr_5()
Dim k&, m&, n&, tms#
tms = Timer
n = 5: m = [a1].End(4).Row: If m < n Then Exit Sub
k = WorksheetFunction.Permut(m, n)
If k < Cells.Rows.Count Then ReDim jg(1 To k, 0 To n)
k = 0:
sj = [a1].Resize(m) '以A列元素为排列对象如 A1="A",A2="B",A3="C",A4="D",A5="E",……
ReDim a&(1 To m)
Dim i1&, i2&, i3&, i4&, i5&
For i1 = 1 To m
a(i1) = 5
For i2 = 1 To m
If a(i2) = 0 Then
a(i2) = 4
For i3 = 1 To m
If a(i3) = 0 Then
a(i3) = 3
For i4 = 1 To m
If a(i4) = 0 Then
a(i4) = 2
For i5 = 1 To m
If a(i5) = 0 Then
k = k + 1
' jg(k, 0) = i1 & "," & i2 & "," & i3 & "," & i4 & "," & i5
' jg(k, 1) = i1 : jg(k, 2) = i2 : jg(k, 3) = i3 : jg(k, 4) = i4 : jg(k, 5) = i5
jg(k, 0) = sj(i1, 1) & sj(i2, 1) & sj(i3, 1) & sj(i4, 1) & sj(i5, 1)
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)
End If
Next
a(i4) = 0
End If
Next
a(i3) = 0
End If
Next
a(i2) = 0
End If
Next
a(i1) = 0
Next
If k > Cells.Rows.Count Then MsgBox Format(Timer - tms, "0.000s ") & k: Exit Sub
[d1].CurrentRegion = "": [d1].Resize(k, n + 1) = jg
[d1].Resize(, n + 1).EntireColumn.AutoFit
MsgBox Format(Timer - tms, "0.000s ") & k
End Sub

复制代码

香川群子 · 发表于 2014-5-15 08:48

输出结果一共有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

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

香川群子 · 发表于 2014-5-15 08:58

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

Sub AutoPermut_3_MidRplMacro()
tms = Timer
Dim k&, m&, n&
n = 3: m = [a1].End(4).Row: If m < n Then Exit Sub
AP = WorksheetFunction.Permut(m, n)
ReDim jg(1 To AP, 0 To n)
sj = [a1].Resize(m)
Dim i1&, s1$, t1$, i2&, s2$, t2$, i3&, s3$, t3$
l = Len("" & m) + 1: t = "," & String(l - 2, "0")
For i1 = 1 To m
s1 = s1 & Right(t & i1, l)
Next
For i1 = 0 To m - 1
t1 = Right(t & i1 + 1, l - 1)
s2 = Replace(s1, "," & t1, "")
For i2 = 0 To m - 2
t2 = Mid(s2, i2 * l + 2, l - 1)
s3 = Replace(s2, "," & t2, "")
For i3 = 0 To m - 3
t3 = Mid(s3, i3 * l + 2, l - 1)
k = k + 1
jg(k, 0) = t1 & "," & t2 & "," & t3
' jg(k, 1) = t1 : jg(k, 2) = t2 : jg(k, 3) = t3
jg(k, 1) = sj(t1, 1): jg(k, 2) = sj(t2, 1): jg(k, 3) = sj(t3, 1)
Next i3, i2, i1
MsgBox k & vbCr & Format(Timer - tms, "0.000s")
End Sub

复制代码

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

Sub AutoPermut_3_FilterMacro()
tms = Timer
Dim k&, m&, n&
n = 3: m = [a1].End(4).Row: If m < n Then Exit Sub
AP = WorksheetFunction.Permut(m, n)
ReDim jg(1 To AP, 0 To n)
sj = [a1].Resize(m)
Dim i1&, t1$, i2&, t2$, i3&, t3$
ReDim s0(m - 1)
For i1 = 1 To m
s0(i1 - 1) = i1
Next
For i1 = 0 To m - 1
t1 = s0(i1): s1 = s0: s1(i1) = "-"
s1 = Filter(s1, "-", False)
For i2 = 0 To m - 2
t2 = s1(i2): s2 = s1: s2(i2) = "-"
s2 = Filter(s2, "-", False)
For i3 = 0 To m - 3
t3 = s2(i3)
k = k + 1
jg(k, 0) = t1 & "," & t2 & "," & t3
' jg(k, 1) = t1 : jg(k, 2) = t2 : jg(k, 3) = t3
jg(k, 1) = sj(t1, 1): jg(k, 2) = sj(t2, 1): jg(k, 3) = sj(t3, 1)
Next i3, i2, i1
MsgBox k & vbCr & Format(Timer - tms, "0.000s")
End Sub

复制代码

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

panzibao · 发表于 2014-5-15 19:31

看不懂什么东西

panzibao · 发表于 2014-5-15 19:40

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

张雄友 · 发表于 2014-5-15 21:11

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

香川群子 · 发表于 2014-5-16 00:03

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

代码看不懂不要紧。

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

香川群子 · 发表于 2014-5-16 00:06

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

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

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

得到的小数允许重复吗？

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

请上附件说明具体要求。

香川群子 · 发表于 2014-5-16 00:07

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

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

		自动登录	找回密码
密码			免费注册

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

评分

评分