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

香川群子 · 发表于 2013-7-4 22:02

组合算法研究的人也很多了。

最简单的是直接For……Next 套用，需要抽n个元素就套用n次……但这样的代码并没有技术含量。
并且因为无法做到自动适应各种m，n数量的变化而不是很理想。

因此，VBA 代码进行任意m、n值的组合算法，也是很有意义的。

……
各种研究结果中，最慢的是二进制算法。因为计算冗余量很大。
普通就有各种数组循环（For……Next 或 Do……Loop）
但由于个人代码写法不同，结果差异也不小。

还有一类是递归算法。
但由于递归算法需要反复调用递归过程等，本质上应该没有直接VBA内数组循环速度快。

…………
其实我自己就写出了很多种不同的版本，最后达到了速度最快，至少我目前还没有发现比我的代码速度更快的组合算法。

更由于我认为我的算法已经是很高效了，达到了极限，无法更加进一步提高效率、缩短计算时间了，
所以今天拿出来分享。

上附件
附件是在Zamyi大侠的附件上，加入了我的代码做了比较。
http://club.excelhome.net/thread-746111-1-1.html
其实Zamyi的代码已经是比一般的代码快很多了（快1倍以上？）

但我的组合算法代码运行速度，比Zamyi大侠的还要快将近 70%

补充内容 (2014-12-20 21:46):
2014年12月20日补充：最新高效代码在135楼：http://club.excelhome.net/forum. ... 055&pid=8004615

香川群子 · 发表于 2013-7-4 22:04

本帖最后由香川群子于 2013-7-8 11:52 编辑

刚才附件加不上啊。

附件做了一些更新，把【组合过程】、【组合并生成组合结果】这两种的运算时间都算出来了。

VBA Combin by kagawa.rar (34.1 KB, 下载次数: 1512)

VBA组合Combin(50,5).jpg

香川群子 · 发表于 2013-7-4 22:05

本帖最后由香川群子于 2013-7-8 11:50 编辑

公布代码，有兴趣可以一起探讨：

'=================================================================
'史上最酷的Excel VBA组合算法【香川Do循环组合】代码特点:
'
'每一次Do……Loop循环都高效地改变一次数组a中组合状态
'用i变量作为元素 1 to m 中的位置指针
'用j变量作为组合结果 1 to n 的数组a位置指针
'用a(j) = i 变量直接赋值方法，比a(j) = a(j) + 1 方式的数组引用赋值要更快一些。
'用If j=n 作为末位循环以及 j-1退位，提高效率。
'并且增加了用 If i = m - n + j 作为退位条件，进一步提高了效率。
' 因为如果j后面状态相同就不用再作计算、变更了所以效率更高一些。
'=================================================================
Sub Combin_kagawa()
Dim i&, j&, k&, l&, m&, n&, s$, tms#
tms = Timer
m = [a1].End(4).Row '获取原始数据最大行数m
sj0 = [a1].Resize(m) '获取原始数据
For i = 1 To m
If Len(sj0(i, 1)) > l Then l = Len(sj0(i, 1)) '找到原始数据各元素中Len的最大值以便统一字符串长度。
Next
n = [b1] '获取组合抽取个数n
s = String(n * l, " ") '字符串变量s初始化为n*l长度的空白字符串s，以便在下面Do循环中进行Mid置换处理
ReDim sj$(1 To m) '定义数组sj 写入统一字符长度的原始数据m个元素。定义为字符型数组可提高速度
For i = 1 To m
sj(i) = Right(s & sj0(i, 1), l) '原始数据调整至同样字符长度
Next
If n = m Then
s = ""
For j = 1 To n
s = s & sj(j) 'n=m 时只有一种组合且需提取全部，所以可直接生成字符串结果s
Next
End If
' k = Application.Combin(m, n) '计算组合结果总数
' ReDim jg$(1 To k, 1 To 1) '定义储存结果的数组jg
' k = 0
'下面才是组合算法的核心部分
ReDim a&(1 To n) '定义数组a存放1 to n各种组合状态位置的信息
a(n) = m: a(1) = 0 '数组a初始化(仅需对1和n两个位置进行初始化赋值，不需要赋值全部就能正常计算)
'循环变量初始化
i = 0 'i含义为当前抽取到元素在原始数据中的序号
j = 1 'j含义为当前抽取到元素在组合结果中的位置序号
Do
i = i + 1 '从1 to m 依次向后抽取第i个元素
a(j) = i '抽取到的元素序号i写入当前组合结果状态数组a中对应j位置
Mid(s, (j - 1) * l + 1, l) = sj(i) '每循环一次都能对不同的状态位作一次有效的元素递增
'上面部分代码看上去特别简单，但这个就是香川组合算法高效的原因所在
If j = n Then '当前抽取元素的组合状态位置到达末位n位置时
k = k + 1
' jg(k, 1) = s '输出结果
If i = m Then If j = 1 Then Exit Do Else j = j - 1: i = a(j) '退出或继续解释略
ElseIf i = m - n + j Then '当前抽取元素的序号i已经满足该位置组合上限m-n+j时
k = k + 1
' jg(k, 1) = s '输出结果
If j = 1 Then Exit Do Else j = j - 1: i = a(j) '退出或继续解释略
Else
j = j + 1 '不满足上述条件时，抽取元素位置j向后移动1
End If
Loop
'组合计算结束
[g65536].End(3).Offset(1) = Format(Timer - tms, "0.000")
[f65536].End(3).Offset(1) = "Combin(" & m & "," & n & ")= " & k
[e65536].End(3).Offset(1) = "kagawa"
If k < 65536 Then [d:d] = "": [d1].Resize(k) = jg '输出结果到工作表
End Sub

复制代码

VBA Combin by kagawa.rar (34.1 KB, 下载次数: 1854)

name004 · 发表于 2013-7-4 22:30

确实很快，了不起，祝贺。

xsy我可以很好 · 发表于 2013-7-4 22:41

{:soso_e179:}{:soso_e177:}

崇拜学习

香川群子 · 发表于 2013-7-4 22:43

这个是我的组合算法的核心部分代码

想要研究的话，看懂这部分就OK了。

Function Combin_kagawa(m&, n&)
Dim i&, j&, k&, r&
tms = Timer
ReDim a&(1 To n)
If n = m Then For j = 2 To n: a(j) = j: Next
i = 0: j = 1: k = 0
Do
' r = r + 1 '统计循环计算总次数实际计算时不需要
i = i + 1: a(j) = i '使用i变量，比单纯a(j) = a(j) + 1 方法赋值要快一些
If j = n Then
k = k + 1
If i = m Then If j = 1 Then Exit Do Else j = j - 1: i = a(j)
ElseIf i = m - n + j Then
k = k + 1
If j = 1 Then Exit Do Else j = j - 1: i = a(j)
Else
j = j + 1
End If
Loop
Combin_kagawa = Format(Timer - tms, "0.000s") & " Do Combin(" & m & "," & n & ")= " & k
End Function

复制代码

香川群子 · 发表于 2013-7-4 22:47

不过，本质上速度最快的，无疑是简单的For……Next循环。

以下专门计算抽取5个元素的组合代码，单纯跑一遍（只进行位置组合，不整理组合结果）只要 0.06秒
但是如果需要整理结果，用直接字符串连接法就需要6秒了。 → 但我的组合算法就只要0.5秒

Sub AutoCombin_5()
tms = Timer
Dim k&, m&, n&, s$
n = 5: m = 50
Dim i1&, i2&, i3&, i4&, i5&
For i1 = 1 To m - 4
For i2 = i1 + 1 To m - 3
For i3 = i2 + 1 To m - 2
For i4 = i3 + 1 To m - 1
For i5 = i4 + 1 To m - 0
k = k + 1
' s = i1 & i2 & i3 & i4 & i5
Next i5, i4, i3, i2, i1
MsgBox k & vbCr & Format(Timer - tms, "0.000s")
End Sub

复制代码

香川群子 · 发表于 2013-7-4 22:52

标准For……Next循环计算组合，组合结果也用Mid方法进行置换的话，速度也还是相当地快，
Combin(50,5)=2118760 只要0.28秒

Sub AutoCombin_Mid_5()
tms = Timer
Dim k&, l&, m&, n&, s$
n = 5: m = [a1].End(4).Row
'AC = WorksheetFunction.Combin(m, n)
'ReDim jg(1 To AC, 0 To n)
sj0 = [a1].Resize(m)
For i = 1 To m
If Len(sj0(i, 1)) > l Then l = Len(sj0(i, 1))
Next
s = String(l, " ")
ReDim sj$(1 To m)
For i = 1 To m
sj(i) = Right(s & sj0(i, 1), l)
Next
s = ""
For i = 1 To n
s = s & sj(i)
Next
Dim i1%, i2%, i3%, i4%, i5%
For i1 = 1 To m - 4
Mid(s, 1, l) = sj(i1)
For i2 = i1 + 1 To m - 3
Mid(s, l * 1 + 1, l) = sj(i2)
For i3 = i2 + 1 To m - 2
Mid(s, l * 2 + 1, l) = sj(i3)
For i4 = i3 + 1 To m - 1
Mid(s, l * 3 + 1, l) = sj(i4)
For i5 = i4 + 1 To m - 0
Mid(s, l * 4 + 1, l) = sj(i5)
k = k + 1
' jg(k, 0) = s
Next i5, i4, i3, i2, i1
MsgBox k & vbCr & Format(Timer - tms, "0.000s")
End Sub

复制代码

香川群子 · 发表于 2013-7-4 23:09

另外，我的递归代码速度也很快……Combin(50,5)=2118760 只要0.6秒

我的递归代码看上去也非常简洁：

Dim sj$(), jg$(), m&, n&, k&
Sub 组合()
tms = Timer: m = [a1].End(4).Row: sj0 = [a1].Resize(m): n = [b1]
ReDim sj$(1 To m): For i = 1 To m: sj(i) = sj0(i, 1): Next
' ReDim jg$(1 To Application.Combin(m, n), 1 To 1)
k = 0: Call dgZH("", 0, 1)
MsgBox k & vbCr & Format(Timer - tms, "0.000s")
End Sub
Sub dgZH(s$, i&, t&)
Dim j&, ss$
For j = i + 1 To m
If t = n Then
k = k + 1
ss = s & sj(j)
' jg(k, 1) = s & sj(j)
Else
Call dgZH(s & sj(j), j, t + 1)
End If
Next
End Sub

复制代码

香川群子 · 发表于 2013-7-7 12:48

我的递归算法，也是最棒的。

尤其是，当Combin(m,n)中，抽取元素个数n远小于元素总数m时，我的递归算法效率相当高。

因为，我在代码中使用了组合元素个数=n时就直接循环输出，而不需要再走一遍递归的处理方法，所以效率提高不少。

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

[原创] 史上最酷的Excel VBA 组合算法代码

评分

点评

评分

[原创] 史上最酷的Excel VBA 组合算法 代码

评分

点评

评分

[原创] 史上最酷的Excel VBA 组合算法代码