[讨论]排列组合之最优算法

364636204

高手啊                                

aoe1981

众里寻它千百度，蓦然回首，依旧还是要靠百度！

aoe1981

先做了一些简单的测试：元素的选取不依赖数字，字母也可以，这样适应性更好，排列组合核心的是元素的位置；输出的文件不是叠加，而是替换，每次都是重新运行后新产生的文件，原有内容被替换掉了……

香川群子

aoe1981 发表于 2014-4-13 12:05
众里寻它千百度，蓦然回首，依旧还是要靠百度！

组合你不向我学习是不行的。

已知所有人的组合算法都不如我。

香川群子

对1楼一般算法（依次向后移位）组合算法的优化改进：

1. Sub test2() '原创： pengxi 一般算法 Reform by kagawa
   
2.    Dim i&, j&, k&, m&, n&, tms#
   
3.     tms = Timer
   
4.    
   
5.     m = [a1].End(4).Row '获取A列最大行数m
   
6.     ReDim sj$(1 To m) '定义字符串变量数组sj
   
7.     For i = 1 To m
   
8.         sj(i) = Cells(i, 1) '原始数据读入字符串变量类型数组可以提升计算速度
   
9.     Next
   
10.    
    
11.     n = [b1] '获取B1单元格中组合提取个数n
    
12.     ReDim a&(1 To n + 1)   '记录各个位置的移动信息
    
13.     ReDim b$(1 To n + 1) '记录中间组合的字符串结果
    
14.    
    
15.     For i = n To 1 Step -1    '记录初始化
    
16.         a(i) = i
    
17. '        b(i) = b(i + 1) & sj(i)   '原代码顺序是从大到小
    
18.         b(i) = sj(i) & b(i + 1)    '顺序改为从小到大
    
19.     Next i
    
20.     a(n + 1) = m + 2 '末位加2以便能最终检查后退出
    
21.    
    
22.     k = Application.Combin(m, n) '计算组合总数k
    
23.     ReDim jg$(1 To k): k = 0 '定义存放结果的数组jg 并让计数值k归零
    
24. 
    
25.     'Open ActiveWorkbook.path & "\CombinResult.txt" For Output As #1   '打开Txt文件 记录组合结果
    
26.     Do
    
27.         k = k + 1
    
28.         jg(k) = b(1) '储存结果
    
29.      'Print #1, b(1) '或存入Txt文件  
    
30. 
    
31.      If a(1) = m - n + 1 Then Exit Do '首位如已经达到最终位置 即已经得到最后一个组合时退出Do循环
    
32.         For j = 1 To n
    
33.             If a(j) + 1 < a(j + 1) Then Exit For '从小到大检查当前可移动位置j  即第一个可以升位的位置
    
34.         Next
    
35.         
    
36.         i = a(j) + 1: a(j) = i '该位置作升位
    
37.         b(j) = sj(i) & b(j + 1) '更新当前位置组合结果
    
38. 
    
39.         For j = j - 1 To 1 Step -1
    
40.             a(j) = j '升位之前的位置全部按递增序号归零 效果如 1,2,3,4……
    
41.             b(j) = sj(j) & b(j + 1) '组合结果也更新
    
42.         Next
    
43.     Loop ' Until a(n) > m '也可设置为当末位超过最大值m时停止
    
44.    'Close #1  '输出到Txt文件时，关闭文件
    
45.     '以下输出结果
    
46.     MsgBox Format(Timer - tms, "0.000s ") & k
    
47.     [f:f] = "": [f1].Resize(k) = Application.Transpose(jg)
    
48. End Sub

复制代码

香川群子

准备继续研究一下，看是否输出结果时还可以提速。

香川群子

对于【彭版元素移动组合算法】的输出部分做了改变。
但运算部分耗时反而稍有增加。
因此，最后只是在n>m/2时有较明显的速度提升。

1. Sub GetCombin_Move() '原pengxi 一般算法 Reform by kagawa
   
2.    Dim i&, j&, k&, m&, n&, tms#
   
3.     tms = Timer
   
4.    
   
5.     m = [a1].End(4).Row
   
6.     n = [b1]
   
7.    
   
8.     ReDim sj1$(m, n)
   
9.     For i = 1 To m
   
10.         For j = 1 To IIf(m - i + 1 > n, n, m - i + 1)
    
11.             sj1(i, j) = sj1(i, j - 1) & Cells(i + j - 1, 1)
    
12.         Next
    
13.     Next
    
14. '    [g1].Resize(m + 1, n + 1) = sj1
    
15.    
    
16.     ReDim a&(1 To n + 1)
    
17.     ReDim b$(1 To n + 1)
    
18.     For i = 1 To n
    
19.         a(i) = i
    
20.     Next
    
21.     a(n + 1) = m + 2 '末位加2以便能最后退出
    
22.    
    
23.     k = Application.Combin(m, n)
    
24.     ReDim jg1$(1 To k, 1 To 1)
    
25.     jg1(1, 1) = sj1(1, n)
    
26.     k = 1
    
27. 
    
28.     'Open ActiveWorkbook.path & "\CombinResult.txt" For Output As #1
    
29.     Do
    
30.         For j = 1 To n
    
31.             If a(j) + 1 < a(j + 1) Then Exit For '从小到大検査当前可移位置j  即第一个可以升位的位置
    
32.         Next
    
33.         i = a(j) + 1: a(j) = i '位置作升位
    
34.         If j > 1 Then
    
35.             If a(j - 1) > j - 1 Then
    
36.                 For l = 1 To j - 1
    
37.                     a(l) = l
    
38.                 Next
    
39.             End If
    
40.         End If
    
41.         
    
42.         t = sj1(i, 1) & b(j + 1): b(j) = t
    
43.         k = k + 1: jg1(k, 1) = sj1(1, j - 1) & t
    
44.         If j > 1 Then
    
45.             If a(j - 1) + 1 < a(j) Then
    
46.                 For l = j - 1 To 1 Step -1
    
47.                     i = a(l) + 1: a(l) = i '
    
48.                     k = k + 1
    
49.                     jg1(k, 1) = sj1(a(1), l - 1) & sj1(i, j - l) & t
    
50.                 Next
    
51.             End If
    
52.         End If
    
53.     Loop Until a(1) = m - n + 1 '也可当末位超最大m停止
    
54.    'Close #1
    
55.    
    
56.    [b14] = Format(Timer - tms, "0.000s kagawa ") & k
    
57.    
    
58.     If [c1] = "" And k < 65536 Then
    
59.         tms = Timer: [f:f] = "": [f1].Resize(k) = jg1: [f1].EntireColumn.AutoFit
    
60.         [b14] = [b14] & " " & Format(Timer - tms, "0.000s")
    
61.     End If
    
62.     Erase jg1
    
63. End Sub
    

复制代码

香川群子

仅作时间测算，或输出组合序号的函数代码：

1. Function Combin_Move(m&, n&) '原pengxiren 元素移动组合算法 Reform by kagawa
   
2.     Dim i&, j&, k&, l&, tms#
   
3.     tms = Timer
   
4.    
   
5.     k = Application.Combin(m, n)
   
6.     ReDim a&(1 To n + 1)
   
7.     ReDim b&(1 To k, 1 To n)
   
8.     k = 1
   
9.     For l = 1 To n
   
10.         a(l) = l
    
11.         b(k, l) = l
    
12.     Next
    
13.     a(n + 1) = m + 2 '末位加2以便能最后退出
    
14.    
    
15.     Do Until a(1) = m - n + 1 '也可当末位超最大m停止
    
16.         For j = 1 To n
    
17.             If a(j) + 1 < a(j + 1) Then Exit For '从小到大検査当前可移位置j  即第一个可以升位的位置
    
18.         Next
    
19.         
    
20.         i = a(j) + 1: a(j) = i '位置作升位
    
21.         If j > 1 Then
    
22.             If a(j - 1) > j - 1 Then
    
23.                 For l = 1 To j - 1
    
24.                     a(l) = l
    
25.                 Next
    
26.             End If
    
27.         End If
    
28.         
    
29.         k = k + 1
    
30.         For l = 1 To n
    
31.             b(k, l) = a(l)
    
32.         Next
    
33.         If j > 1 Then
    
34.             If a(j - 1) + 1 < a(j) Then
    
35.                 For i = j - 1 To 1 Step -1
    
36.                     a(i) = a(i) + 1
    
37.                     k = k + 1
    
38.                     For l = 1 To n
    
39.                         b(k, l) = a(l)
    
40.                     Next
    
41.                 Next
    
42.             End If
    
43.         End If
    
44.     Loop
    
45.     Combin_Move = b
    
46. '    Combin_Move = Format(Timer - tms, "0.000s ") & " Move Combin(" & m & "," & n & ")= " & k
    
47.    
    
48. End Function
    

复制代码

彭希仁

laoau132 发表于 2015-5-8 18:06
你继续吹吧，倚天不出谁与争锋一招就秒了你

我是很服香川群子的，她比我牛。哈哈