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

香川群子

下面是递归方法实现全排列【两两交换】算法的代码：

1. Dim sj, jg, l%, n%, k&
   
2. Sub 排列2()
   
3. 
   
4.     n = [a1].End(4).Row
   
5.     sj = [a1].Resize(n)
   
6.     '以上取A列待排列元素到原始数据sj
   
7.    
   
8.     l = Len(sj(1, 1))
   
9.     For i = 2 To n
   
10.         If Len(sj(i, 1)) > l Then l = Len(sj(i, 1))
    
11.     Next
    
12.     ' l = l + 1
    
13.     For i = 1 To n
    
14.         sj(i, 1) = String(l - Len(sj(i, 1)), " ") & sj(i, 1)
    
15.     Next
    
16.     '递归过程将直接引用各排列的字符串結果，因此以上是将原始数据字符串長度統一。
    
17.    
    
18.     AP = WorksheetFunction.Permut(n, 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 > n Then jg(k, 0) = s: k = k + 1 '到指定个数n即把排列結果写入jg
    
32.     If t <= n Then Call pldg2(s & sj(t, 1), t, t + 1) '如果个数不到n则继续調用递归过程增加元素个数
    
33.     If i > 1 Then '抽取元素个数超1个(2个以上)时，从末位降序逐个进行【両両置換】
    
34.         Mid(s, (i - 1) * l + 1, l) = Mid(s, (i - 2) * l + 1, l) '后位置字符交换成前一位置字符
    
35.         Mid(s, (i - 2) * l + 1, l) = sj(t - 1, 1) '前位置字符交换成当前要交换位置字符(新添字符)
    
36.         Call pldg2(s, i - 1, t) '交換完成的結果，递归進入下一層
    
37.     End If
    
38. End Sub
    

复制代码

速度也很给力。

香川群子

最后这个，是从m个元素中任意取数n个时，排列组合结果的递归代码：
用了组合递归过程中嵌套进行【两两置换】排列递归的算法。

1. Sub 排列組合()
   
2.     tms = Timer
   
3.    
   
4.     m = [a1].End(4).Row:    sj = [a1].Resize(m) '获取原始数据读入数组sj
   
5.     l = Len(sj(1, 1))
   
6.     For i = 2 To m
   
7.         If Len(sj(i, 1)) > l Then l = Len(sj(i, 1))
   
8.     Next
   
9. '    l = l + 1
   
10.     For i = 1 To m
    
11.         sj(i, 1) = String(l - Len(sj(i, 1)), " ") & sj(i, 1)
    
12.     Next
    
13.    '以上为统一原始数据字符串长度
    
14.    
    
15.     n = [b1] '\获取抽取个数n
    
16.     AP = WorksheetFunction.Permut(m, n):
    
17.     [b3] = WorksheetFunction.Combin(m, n) & "x" & WorksheetFunction.Permut(n, n) & "=" & AP
    
18.     ReDim jg(AP, 0) '定义储存结果的数组jg
    
19.    
    
20.     k = 0: cnt = 0: tms = Timer
    
21.     Call plzhdg("", 0, 0) '调用排列组合递归过程
    
22.    
    
23.     [b9] = Format(Timer - tms, "0.000s ") & cnt & "/" & k
    
24.     If k < 65536 Then tms = Timer: [g:g] = "": [g1].Resize(k) = jg: [b10] = Timer - tms
    
25.     '输出结果
    
26. End Sub
    
27. 
    
28. Sub plzhdg(s$, i%, t%)
    
29.   '排列组合递归过程，但实际上核心部分是组合递归过程。
    
30.    Dim j%
    
31.     cnt = cnt + 1
    
32.     For j = i + 1 To m
    
33.         If t + 1 < n Then
    
34.             Call plzhdg(s & "," & sj(j, 1), j, t + 1)
    
35.         Else
    
36.             sj2 = Split(s & "," & sj(j, 1), ",") '最后的组合结果转换为数组sj2
    
37.             Call pldg2("", 0, 1) '然后对此组合结果调用【两两交换】算法的全排列递归过程
    
38.         End If
    
39.     Next
    
40. End Sub
    
41. Sub pldg2(s$, i%, t%) '【两两交换】算法的全排列递归过程，解释略
    
42.     cnt = cnt + 1
    
43.     If t > n Then jg(k, 0) = s: k = k + 1
    
44.     If t <= n Then Call pldg2(s & sj2(t), t, t + 1)
    
45.     If i > 1 Then
    
46.         Mid(s, (i - 1) * l + 1, l) = Mid(s, (i - 2) * l + 1, l)
    
47.         Mid(s, (i - 2) * l + 1, l) = sj2(t - 1)
    
48.         Call pldg2(s, i - 1, t)
    
49.     End If
    
50. End Sub
    

复制代码

香川群子

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

呵呵，研究发现【两两交换】的算法，可以更简单：

上次我是从末位位置开始，倒序两两交换。

这一次，我改成了每次都只是首位和末位进行【首尾交换】，结果算法更简单了。

第一步：
1→ 12 → 21

第二步：
12→123 → 312 → 231
21→213 → 321 → 132

第三部：
123→1234 →4123 →3412 →2341
312→3124 →4312 →2431 →1243
……

以此类推。

下面图片，是三种不同的位置交换算法时，对于最后一位的位置变化得到的图形结果。
很有趣。

香川群子

我的两种位置交换算法的代码。
今后还要继续改进。

1. Sub GetPermutReplaceStr()
   
2.     tms = Timer '0.2s
   
3.     Dim AP&, i%, j&, k&, l%, m%, n%, s$, t$
   
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.    
    
16.     AP = 1
    
17.     ReDim x(1 To 1)
    
18.     ReDim y(1 To 1)
    
19.     y(1) = sj(1, 1)
    
20.     [b9] = Format(Timer - tms, "0.000s jg ")
    
21.    
    
22.     tms = Timer
    
23.     For i = 2 To n
    
24.         x = y
    
25.         ReDim Preserve y(1 To AP * i)
    
26.         k = 0
    
27.         For j = 1 To AP
    
28.             t = sj(i, 1)
    
29.             s = x(j) & t
    
30.             k = k + 1: y(k) = s
    
31.             For p = i - 1 To 1 Step -1
    
32.                 Mid(s, p * l + 1, l) = Mid(s, (p - 1) * l + 1, l)
    
33.                 Mid(s, (p - 1) * l + 1, l) = t
    
34.                 k = k + 1: y(k) = s
    
35.             Next
    
36.         Next
    
37.         AP = AP * i
    
38.     Next
    
39.     [b9] = [b9] & "/" & Format(Timer - tms, "0.000s ") & AP
    
40.     If AP < 65536 Then [f:f] = "": [f1].Resize(AP) = Application.Transpose(y)
    
41.    
    
42.    
    
43.     AP = 1
    
44.     ReDim x(1 To 1)
    
45.     ReDim y(1 To 1)
    
46.     y(1) = sj(1, 1)
    
47.    
    
48.     tms = Timer
    
49.     For i = 2 To n
    
50.         x = y
    
51.         ReDim Preserve y(1 To AP * i)
    
52.         k = 0
    
53.         For j = 1 To AP
    
54.             t = sj(i, 1)
    
55.             s = x(j) & t
    
56.             k = k + 1: y(k) = s
    
57.             For p = i - 1 To 1 Step -1
    
58.                 s = Right(s, l) & Left(s, (i - 1) * l)
    
59.                 k = k + 1: y(k) = s
    
60.             Next
    
61.         Next
    
62.         AP = AP * i
    
63.     Next
    
64.     [b10] = Left([b9], 10) & "/" & Format(Timer - tms, "0.000s ") & AP
    
65.     If AP < 65536 Then [g:g] = "": [g1].Resize(AP) = Application.Transpose(y)
    
66.    
    
67. End Sub

复制代码

香川群子

我研究了一下【两两交换算法】，
按照新元素添加顺序有两种（后接、前缀），
交换方法有四种（首到尾交换、尾到首交换、降序相邻交换、升序相邻交换）

发现其中只有6种可以得到正确排序结果，有二种会产生重复错误。
（后接升序交换、前缀降序交换）


呵呵。
吴姐的交换顺序还是不太懂，姑且称之为【蛇行交换】吧。

534

请教香子美女，在excel2010中，任意Permut(m,n)的全部排列结果，当m=13,n=5，排列数达到154440时，得不到任何排列结果。请问是怎么回事？在线等！