史上最酷的Excel VBA 组合算法 代码

香川群子

1. 
   
2. Sub test2()
   
3.     Dim m&, n&
   
4.     m = 26
   
5.     For n = 1 To m
   
6.         MsgBox CombinDo(m, n) & vbCr & CombinDo2(m, n)
   
7.     Next
   
8. End Sub
   
9. Function CombinDo2(ByVal m&, ByVal n&)
   
10.     Dim i&, j&, k&
    
11.     tms = Timer
    
12.    
    
13.     n = n - 1: ReDim a&(n)
    
14.     For j = 0 To n - 1
    
15.         a(j) = 1 + j
    
16.     Next
    
17.     If 1 + n = m Then a(n) = m: CombinDo2 = "0.0000s  Do2 Combin(" & m & "," & 1 + n & ")= 1": Exit Function
    
18.    
    
19.     i = n ': j = n: k = 0
    
20.     Do
    
21.         For i = i + 1 To m
    
22. '            a(j) = i
    
23.             k = k + 1
    
24.         Next
    
25.         
    
26.         For j = j - 1 To 0 Step -1
    
27.             i = a(j) + 1
    
28.             a(j) = i
    
29.             If i = m - n + j Then
    
30.                 k = k + 1
    
31.             Else
    
32.                 j = j + 1
    
33.                 Do Until j = n
    
34.                     i = i + 1
    
35.                     a(j) = i
    
36.                     j = j + 1
    
37.                 Loop
    
38.                 If i < m Then Exit For
    
39.             End If
    
40.         Next
    
41.     Loop Until j = -1
    
42.     CombinDo2 = Format(Timer - tms, "0.0000s ") & " Do2 Combin(" & m & "," & 1 + n & ")= " & k
    
43.    
    
44. End Function
    
45. Function CombinDo(ByVal m&, ByVal n&)
    
46.     Dim i&, j&, k&, r&
    
47.     If n = 1 Or n = m Then CombinDo = "0.0000s  Do  Combin(" & m & "," & n & ")= " & IIf(n = 1, m, 1): Exit Function
    
48.     tms = Timer
    
49.    
    
50.     n = n - 1: ReDim a&(n)
    
51.     For j = 0 To n - 1
    
52.         a(j) = 1 + j
    
53.     Next
    
54.    
    
55.     i = n ': j = n: k = 0
    
56.     Do
    
57.         i = i + 1: a(j) = i
    
58.         
    
59.         If j = n Then
    
60.             k = k + 1
    
61. '            If i = m Then If 1 + n = m Or n = 0 Then Exit Do Else j = j - 1: i = a(j)
    
62.             If i = m Then j = j - 1: i = a(j)
    
63.         ElseIf i = m - n + j Then
    
64.             k = k + 1
    
65.             If j = 0 Then Exit Do Else j = j - 1: i = a(j)
    
66.         Else
    
67.             j = j + 1
    
68.         End If
    
69.     Loop
    
70.     CombinDo = Format(Timer - tms, "0.0000s ") & " Do  Combin(" & m & "," & 1 + n & ")= " & k
    
71. End Function
    

复制代码

笑看幸福

新手，看得有点晕乎乎的感觉，到底从那入手

香川群子

代码又做了些改进，居然又提高了20%的速度。

1. Sub GetCombinMid2()
   
2.     Dim i&, j&, k&, l&, m&, n&, s$
   
3.     m = [a1].End(4).Row: sj = [a1].Resize(m): n = [b1]
   
4.    
   
5.     tms = Timer
   
6.     If n = m Then [d1] = Join(Application.Transpose(sj), ""): Exit Sub
   
7.    
   
8.     For j = 1 To m
   
9.         If Len(sj(j, 1)) > l Then l = Len(sj(j, 1))
   
10.     Next
    
11.     ReDim sj1$(1 To m)
    
12.     s = String(l, " ")
    
13.     For j = 1 To m
    
14.         sj1(j) = Right(s & sj(j, 1), l)
    
15.     Next
    
16.    
    
17.     k = Application.Combin(m, n)
    
18.     s = String(l * n, " ")
    
19.     n = n - 1: ReDim a&(n)
    
20.     For j = 0 To n - 1
    
21.         a(j) = 1 + j
    
22.         Mid(s, j * l + 1, l) = sj1(1 + j)
    
23.     Next
    
24.    
    
25.     ReDim jg$(1 To k, 1 To 1)
    
26.    
    
27.     i = n: k = 0
    
28.     Do
    
29.         For i = i + 1 To m
    
30.             'a(j) = i
    
31.             Mid(s, j * l + 1, l) = sj1(i)
    
32.             k = k + 1: jg(k, 1) = s
    
33.         Next
    
34.         
    
35.         For j = j - 1 To 0 Step -1
    
36.             i = a(j) + 1: a(j) = i
    
37.             Mid(s, j * l + 1, l) = sj1(i)
    
38.             If i = m - n + j Then
    
39.                 k = k + 1: jg(k, 1) = s
    
40.             Else
    
41.                 j = j + 1
    
42.                 Do Until j = n
    
43.                     i = i + 1: a(j) = i
    
44.                     Mid(s, j * l + 1, l) = sj1(i)
    
45.                     j = j + 1
    
46.                 Loop
    
47.                 If i < m Then Exit For
    
48.             End If
    
49.         Next
    
50.     Loop Until j = -1
    
51.     MsgBox Format(Timer - tms, "0.000s kagawa CombinDoMid2 ") & k
    
52.    
    
53.     If k < 65536 Then [d:d] = "": [d1].Resize(k) = jg: [d1].EntireColumn.AutoFit
    
54.     Erase jg
    
55.    
    
56. End Sub
    
57. 
    

复制代码

学不完用不尽

测试了这样一组数据：0、10、3、8、1、2、6、4、0、0，抽取3个时，貌似有误。
请测试！

香川群子

学不完用不尽 发表于 2013-9-23 22:37
测试了这样一组数据：0、10、3、8、1、2、6、4、0、0，抽取3个时，貌似有误。
请测试！

我的代码是不可能有错误的。是你的要求有问题。

你的10个原始数据中0重复了3次……你想要得到什么样的组合结果呢？

根据要求不同，需要不同的代码。


…………
10个元素抽取3个应该得到 =Combin(10,3)=120 组合，或者 =Permut(10,3)=720 排列组合

但如果需要排除3个重复的0，则只有64个不重复组合结果，或者274个不重复排列结果。

下面是64组不同的组合：
0,0,0;0,0,1;0,0,2;0,0,3;0,0,4;0,0,6;0,0,8;0,0,10;0,1,2;0,1,3;0,1,4;0,1,6;0,1,8;0,1,10;0,2,3;0,2,4;
0,2,6;0,2,8;0,2,10;0,3,4;0,3,6;0,3,8;0,3,10;0,4,6;0,4,8;0,4,10;0,6,8;0,6,10;0,8,10;1,2,3;1,2,4;1,2,6;
1,2,8;1,2,10;1,3,4;1,3,6;1,3,8;1,3,10;1,4,6;1,4,8;1,4,10;1,6,8;1,6,10;1,8,10;2,3,4;2,3,6;2,3,8;2,3,10;
2,4,6;2,4,8;2,4,10;2,6,8;2,6,10;2,8,10;3,4,6;3,4,8;3,4,10;3,6,8;3,6,10;3,8,10;4,6,8;4,6,10;4,8,10;6,8,10




补充内容 (2014-4-18 14:59):
更正：10个元素中3个相同，其余7个各自不同，那么不重复的排列组合共有358个。之前0值处理有误导致结果错误。

彭希仁

牛逼的群子

ctp_119

香川群子 发表于 2013-7-15 14:07
自己顶一次。

香川群子的组合算法最棒！

的确很棒！！！学习中！

香川群子

彭希仁 发表于 2013-9-24 15:58
牛逼的群子

呵呵，当抽取数n>m/2(元素总数一半以上)，尤其是接近m时，

使用我的算法，比单纯的循环速度都快。

本来我自己都认为循环是组合算法速度的极限了。


…………
彭版有空研究一下我的算法思路。

关键是，我采用的直接升位法，

比如，8个元素中抽取5个时， 对于 1,4,5,6,7 状态，我可以直接一步升位一次：
   1,4,5,6,7
→ 1,4,5,6,8
→ 1,4,5,7,8
→ 1,4,6,7,8
→ 1,5,6,7,8

然后才是：
→ 2,3,4,5,6

这么做会节省很多时间的。


另外一个算法速度快的原因是：
i 变量（元素位置）和j 变量（组合位置）的直接计算高效使用，几乎不进行数组件元素的计算。


所以，目前世界上Excel VBA代码中，还没有比我更好的算法。

学不完用不尽

香川群子 发表于 2013-9-24 10:25
我的代码是不可能有错误的。是你的要求有问题。

你的10个原始数据中0重复了3次……你想要得到什么样 ...

第二次运行又正确了，不好意思啊！

jinbo3535

追求完美的裙子老师···
留个脚印学习···