[已解决]枚举不重复排列的问题，我的方法效率低，求指点

wcymiss

1. Sub 全排列()
   
2.     Dim n As Integer, arr(), brr()
   
3.     Dim d() As Integer, e() As Integer, Temp As String
   
4.     Dim i As Integer, j As Integer, k As Integer, m As Long
   
5.     Dim t
   
6.     t = Timer
   
7.     n = Cells(Rows.Count, 1).End(xlUp).Row
   
8.     arr = Application.Transpose(Range("a1:a" & n).Value)
   
9.     m = 1
   
10.     For i = 1 To n: m = m * i: Next '求出总个数
    
11.     ReDim brr(1 To m, 1 To 1), d(1 To n), e(1 To n)
    
12.     For i = 1 To n: d(i) = i: e(i) = -1: Next '初始化
    
13.     m = 0
    
14. line: m = m + 1: brr(m, 1) = Join(arr, "")
    
15.     k = 0
    
16.     For i = n To 2 Step -1
    
17.         d(i) = d(i) + e(i)
    
18.         If d(i) = i Then
    
19.             e(i) = -1
    
20.         ElseIf d(i) = 0 Then
    
21.             k = k + 1: e(i) = 1
    
22.         Else
    
23.             j = d(i) + k '定位
    
24.             Temp = arr(j): arr(j) = arr(j + 1): arr(j + 1) = Temp '交换位置
    
25.             GoTo line
    
26.         End If
    
27.     Next
    
28.     MsgBox Timer - t
    
29.     Range("e:e").ClearContents
    
30.     Range("e1").Resize(UBound(brr), 1) = brr
    
31. End Sub

复制代码

hyqzzs

wcymiss 发表于 2012-11-7 22:26

呵呵，香川的代码我还没看懂，又来了个高手，保存，再研究。谢谢指点

香川群子

wcymiss 发表于 2012-11-7 22:26

吴姐你好！

你的全排列算法代码我看了，很牛。

算法原理我理解是通过【两两置换】来产生所有不同的排列结果。

但是具体算法实现方法，即位置参数的调整算法，保证既不重复也无遗漏的算法原理，到现在也没有理解。


不过，受【两两置换】方法思路的启发，我直接改写成了递归算法代码，结果还算成功，计算时间反而有所提高。

1. Dim sj, jg, l%, m%, k&
   
2. Sub 递归排列2()
   
3. 
   
4. m = [a1].End(4).Row
   
5. sj = [a1].Resize(m)
   
6. '以上为获取A列元素作为待排列的原始数据到数组sj
   
7. 
   
8. l = Len(sj(1, 1))
   
9. For i = 2 To m
   
10. If Len(sj(i, 1)) > l Then l = Len(sj(i, 1))
    
11. Next
    
12. ' l = l + 1
    
13. For i = 1 To m
    
14. sj(i, 1) = String(l - Len(sj(i, 1)), " ") & sj(i, 1)
    
15. Next
    
16. '递归函数将直接传递各种排列的字符串结果，因此以上过程是为了统一原始数据字符串长度。
    
17. 
    
18. AP = WorksheetFunction.Permut(m, n)
    
19. ReDim jg(AP, 0) '定义储存结果的数组jg
    
20. 
    
21. k = 0: tms = Timer
    
22. Call pldg2("", 0, 1) '开始递归过程
    
23. 
    
24. MsgBox Format(Timer - tms, "0.000s")
    
25. [d:d] = ""
    
26. [d1].Resize(AP) = jg '输出结果
    
27. 
    
28. End Sub
    
29. 
    
30. Sub pldg2(s$, i%, t%)
    
31.     If t > m Then jg(k, 0) = s: k = k + 1 '递归到指定个数m时把排列结果写入结果数组jg
    
32.     If t <= m Then Call pldg2(s & sj(t, 1), t, t + 1) '如果不到指定个数m时继续调用递归过程计算以增加元素个数
    
33.     If i > 1 Then '抽取元素个数超过1个时（两个以上时），就从末位开始降序进行逐个【两两交换】
    
34.         If i > 2 Then t1 = Mid(s, 1, (i - 2) * l) Else t1 = ""  '计算确定交换前字符串t1
    
35.         t2 = Mid(s, (i - 1) * l + 1, l) '计算确定要向前交换的字符t2
    
36.         t3 = Mid(s, (i - 2) * l + 1, l) '计算确定要向后交换的字符t3
    
37.         t4 = Mid(s, i * l + 1)  '计算确定不需要交换的剩余字符t4
    
38.         s = t1 & t2 & t3 & t4 '最后合并，完成交换。 即从t1-t3-t2-t4，交换为t1-t2-t3-t4的结果
    
39.         Call pldg2(s, i - 1, t) '对交换完成的结果，继续调用进入下一层递归计算。
    
40.     End If
    
41. End Sub

复制代码

香川群子

wcymiss 发表于 2012-11-7 22:26

吴姐你好！

按上面递归同样的思路，也写了一个数组循环的算法。
不过很勉强，用到了辅助数组来储存【两两交换】后的中间计算结果，算法效率较低。

但是，思路比较容易理解。

比如： 1234共4个元素的全排列计算：
一.  从元素1开始；
二.  从For i = 2 to m 开始循环：
   1. 添加后面元素2，那么就生成了 1&2=12；
   2. 然后把这个结果进行交换，就有了 2&1=21；
   3. Next 继续循环……
三. 多重循环直到凑满m个元素时输出结果。

上面过程的实例：
1 →12 → 21 → 【1添加2得到12，然后换位得到21】
→12→123→132→312→【12继续添加3得到123，然后换位得到132,312】
→21→213→231→321→【21继续添加3得到213，然后换位得到231,321】

接下来就可以得到最终结果了。
→123添加4  →1234→1243→1423→4123
→132添加4  →1324→1342→1432→4132
→312添加4  →3124→3142→3412→4312
→213添加4  →2134→2143→2413→4213
→231添加4  →2314→2341→2431→4231
→321添加4  →3214→3241→3421→4321
  

香川群子

这个是我写的【两两交换】数组法代码：

1. Sub GetPermutReplace()
   
2.     Dim AP&, i%, j&, k&, l%, m%, n%
   
3.     tms = Timer
   
4.    
   
5.     m = [a1].End(4).Row
   
6.     arr = [a1].Resize(m)
   
7.    
   
8.     ReDim a(1 To n)
   
9.     a(1) = arr(1, 1)
   
10.    
    
11.     AP = 1
    
12.     ReDim x(1 To AP)
    
13.     ReDim y(1 To AP)
    
14.     y(1) = a
    
15.    
    
16.     tms = Timer
    
17.     For i = 2 To m
    
18.         x = y
    
19.         ReDim Preserve y(1 To AP * i)
    
20.         k = 0
    
21.         For j = 1 To AP
    
22.             t = x(j)
    
23.             t(i) = arr(i, 1)
    
24.             k = k + 1
    
25.             If i < m Then y(k) = t Else y(k) = Join(t, "")
    
26.             For l = i To 2 Step -1
    
27.                 tmp = t(l - 1): t(l - 1) = t(l): t(l) = tmp
    
28.                 k = k + 1
    
29.                 If i < m Then y(k) = t Else y(k) = Join(t, "")
    
30.             Next
    
31.         Next
    
32.         AP = AP * i
    
33.     Next
    
34.     MsgBox Format(Timer - tms, "0.000s")
    
35.    
    
36.     [d:d] = ""
    
37.     [d1].Resize(AP) = Application.Transpose(y)
    
38.    
    
39. End Sub

复制代码

xdwy81129

香川群子 发表于 2012-12-23 19:49
吴姐你好！

你的全排列算法代码我看了，很牛。

没有仔细看代码，原来的代码计算准确，而且比宏“全排列”快呀

.078125秒  全排列
.046875秒  原代码


可是我执行新代码却出现错误，奇怪了

香川群子

wcymiss 发表于 2012-11-7 22:26

最后是我的压箱底任意取数排列数组循环算法代码：

1. Sub GetPermutArray()
   
2. Dim AP&, i&, j%, k%, m%, n%
   
3. tms = Timer
   
4. 
   
5. m = [a1].End(4).Row
   
6. arr = [a1].Resize(m)
   
7. 
   
8. n = [b1]
   
9. AP = WorksheetFunction.Permut(m, n)
   
10. [b3] = AP
    
11. 
    
12. ReDim a%(1 To n)
    
13. ReDim b%(1 To m)
    
14. 
    
15. For i = 1 To n - 1
    
16. a(i) = i
    
17. b(a(i)) = 1
    
18. Next
    
19. a(n) = n
    
20. 
    
21. ReDim crr(1 To AP, 1 To 1)
    
22. For i = 1 To AP
    
23. crr(i, 1) = arr(a(1), 1)
    
24. For j = 2 To n
    
25. crr(i, 1) = crr(i, 1) & arr(a(j), 1)
    
26. Next j
    
27. 
    
28. If a(n) < m Then
    
29. For j = a(n) + 1 To m
    
30. If b(j) = 0 Then
    
31. a(n) = j
    
32. GoTo NxtI
    
33. End If
    
34. Next
    
35. Else
    
36. If n = 1 Then GoTo NxtI 'n=1
    
37. End If
    
38. 
    
39. 
    
40. For j = n - 1 To 1 Step -1
    
41. b(a(j)) = 0
    
42. If a(j) < m Then
    
43. For k = a(j) + 1 To m
    
44. If b(k) = 0 Then
    
45. a(j) = k
    
46. b(k) = 1
    
47. GoTo NxtJ
    
48. End If
    
49. Next
    
50. End If
    
51. Next
    
52. NxtJ:
    
53. For j = j + 1 To n
    
54. For k = 1 To m
    
55. If b(k) = 0 Then
    
56. a(j) = k
    
57. If j < n Then b(k) = 1
    
58. Exit For
    
59. End If
    
60. Next
    
61. Next
    
62. NxtI:
    
63. Next
    
64. 
    
65. MsgBox Format(Timer - tms, "0.000s")
    
66. [d:d] = ""
    
67. [d1].Resize(AP) = crr
    
68. End Sub
    

复制代码

香川群子

xdwy81129 发表于 2012-12-23 20:15
没有仔细看代码，原来的代码计算准确，而且比宏“全排列”快呀

.078125秒  全排列

新代码出错？

需要提醒你注意的是，
全排列代码仅仅能够计算n个元素的n!的全部排列结果代码。

而不能计算n个元素中任取m个组合，然后组合结果再进行“全”排列的排列组合结果。

……
相应的，我原来的代码可以这样计算。

香川群子

用递归组合嵌套递归排列（置换算法）后的可计算任意组合的代码：

1. Dim sj, sj2, jg, l%, m%, n%, k&
   
2. Sub 递归排列组合()
   
3.     tms = Timer
   
4.    
   
5.     m = [a1].End(4).Row:    sj = [a1].Resize(m)
   
6.     l = Len(sj(1, 1))
   
7.     For i = 2 To n
   
8.         If Len(sj(i, 1)) > l Then l = Len(sj(i, 1))
   
9.     Next
   
10. '    l = l + 1
    
11.     For i = 1 To n
    
12.         sj(i, 1) = String(l - Len(sj(i, 1)), " ") & sj(i, 1)
    
13.     Next
    
14.    
    
15.     n = [b1]: [b3] = WorksheetFunction.Combin(m, n):
    
16.     ACP = WorksheetFunction.Permut(m, n): [b4] = ACP
    
17.     ReDim jg(ACP, 0)
    
18.    
    
19.     k = 0: Call plzhdg("", 0, 0)
    
20.    
    
21.     [d:d] = "":    [d1].Resize(ACP) = jg
    
22. End Sub
    
23. Sub plzhdg(s$, i%, t%)
    
24.     Dim j%
    
25.     For j = i + 1 To m
    
26.         If t + 1 < n Then
    
27.             Call plzhdg(s & "," & sj(j, 1), j, t + 1)
    
28.         Else
    
29.             sj2 = Split(s & "," & sj(j, 1), ",")
    
30.             Call pldg2("", 0, 1)
    
31.         End If
    
32.     Next
    
33. End Sub
    
34. Sub pldg2(s$, i%, t%)
    
35.     If t > n Then jg(k, 0) = s: k = k + 1
    
36.     If t <= n Then Call pldg2(s & sj2(t), t, t + 1)
    
37.     If i > 1 Then
    
38.         If i > 2 Then t1 = Mid(s, 1, (i - 2) * l) Else t1 = ""
    
39.         t2 = Mid(s, (i - 1) * l + 1, l)
    
40.         t3 = Mid(s, (i - 2) * l + 1, l)
    
41.         t4 = Mid(s, i * l + 1)
    
42.         s = t1 & t2 & t3 & t4
    
43.         Call pldg2(s, i - 1, t)
    
44.     End If
    
45. End Sub

复制代码

香川群子

呵呵，经过研究，两两交换可以用mid()函数直接操作，省去了一步……

因此，目前我的代码速度已经超过了吴姐的速度了。

下面是数组循环方式的【两两置换】算法应用。
但是采用了字符串方式操作，和吴姐的直接内存数组内交换方法不同。

1. Sub GetPermutReplaceStr()
   
2.     Dim AP&, i%, j&, k&, l%, m%, n%, s$, t$
   
3.     tms = Timer
   
4.    
   
5.     n = [a1].End(4).Row
   
6.     sj = [a1].Resize(n)
   
7.     l = Len(sj(1, 1))
   
8.     For i = 2 To n
   
9.         If Len(sj(i, 1)) > l Then l = Len(sj(i, 1))
   
10.     Next
    
11. '    l = l + 1
    
12.     For i = 1 To n
    
13.         sj(i, 1) = String(l - Len(sj(i, 1)), " ") & sj(i, 1)
    
14.     Next
    
15.     '以上为统一原始数据中字符串长度，以便今后mid置换操作时能够准确定位   
    
16. 
    
17.     AP = 1
    
18.     ReDim x(1 To 1)
    
19.     ReDim y(1 To 1)
    
20.     y(1) = sj(1, 1)
    
21.     '以上为建立辅助用的数组x、数组y，用来存放中间计算结果。（和递归作用同样的意思）
    
22. 
    
23. '    tms = Timer '正式开始【两两交换】计算
    
24.     For i = 2 To n
    
25.         x = y '把上次计算的储存结果y导入辅助x中，开始新一轮遍历处理计算
    
26.         ReDim Preserve y(1 To AP * i) '扩大辅助y行数以便储存新的结果
    
27.         k = 0 '定位指针归零
    
28.         For j = 1 To AP
    
29.             t = sj(i, 1) '本轮元素作为置换字符t
    
30.             s = x(j) & t '从上轮次结果x中依次获取结果并添加t
    
31.             k = k + 1 : y(k) = s '结果存入y
    
32.             For p = i - 1 To 1 Step -1 '刚才获取新组合结果进行【倒序置换】
    
33.                 Mid(s, p * l + 1, l) = Mid(s, (p - 1) * l + 1, l) 'p位置用前一位置字符置换
    
34.                 Mid(s, (p - 1) * l + 1, l) = t 'p的前一位置直接用本轮新添元素t字符置换
    
35.                 k = k + 1 : y(k) = s '结果存入y
    
36.             Next
    
37.         Next
    
38.         AP = AP * i  '计算下一轮次结果总数，作为数组y大小扩大的依据。
    
39.     Next
    
40.     MsgBox Format(Timer - tms, "0.000s") '计算完成
    
41.    
    
42.     [f:f] = ""
    
43.     [f1].Resize(AP) = Application.Transpose(y) '输出结果
    
44.    
    
45. End Sub
    

复制代码