求排列组合结果的自定义函数

lee1892 · 发表于 2014-12-18 17:45

香川群子发表于 2013-9-17 14:23
2013年最新研究成果：

世上最快速度的Excel VBA 组合算法核心部分：计算下面1千万的组合只要1.723秒。（ ...

代码大致看明白了，速度提高余地还蛮大的哦～

lee1892 · 发表于 2014-12-19 10:37

本帖最后由 lee1892 于 2014-12-19 10:39 编辑

51 楼代码改进后的效果，由2.1秒加速到1.6秒不到，20%+

========================================
Chose 13 From 27 Test #1:
Original From 香川: 2.125s 20058300
Change Inner DO to FOR: 1.953s 20058300
Remove One IF: 1.656s 20058300
Remove Outer DO: 1.578s 20058300
Final Work by Lee1892: 1.547s 20058300
========================================
Chose 13 From 27 Test #2:
Original From 香川: 2.109s 20058300
Change Inner DO to FOR: 1.969s 20058300
Remove One IF: 1.656s 20058300
Remove Outer DO: 1.578s 20058300
Final Work by Lee1892: 1.547s 20058300
========================================
Chose 13 From 27 Test #3:
Original From 香川: 2.109s 20058300
Change Inner DO to FOR: 1.953s 20058300
Remove One IF: 1.641s 20058300
Remove Outer DO: 1.563s 20058300
Final Work by Lee1892: 1.563s 20058300
========================================
Chose 13 From 27 Test #4:
Original From 香川: 2.156s 20058300
Change Inner DO to FOR: 2.031s 20058300
Remove One IF: 1.641s 20058300
Remove Outer DO: 1.609s 20058300
Final Work by Lee1892: 1.594s 20058300
========================================
Chose 13 From 27 Test #5:
Original From 香川: 2.141s 20058300
Change Inner DO to FOR: 2.000s 20058300
Remove One IF: 1.656s 20058300
Remove Outer DO: 1.609s 20058300
Final Work by Lee1892: 1.563s 20058300

复制代码

代码改进的过程如下：

Private Sub TestSpeed()
Dim i%, m&, n&
m = 27
n = 13
For i = 1 To 5
Debug.Print String(40, "=")
Debug.Print "Chose " & n & " From " & m & " Test #" & i & ":"
Debug.Print " Original From 香川: "; Combin_1(m, n)
Debug.Print "Change Inner DO to FOR: "; Combin_2(m, n)
Debug.Print " Remove One IF: "; Combin_3(m, n)
Debug.Print " Remove Outer DO: "; Combin_4(m, n)
Debug.Print " Final Work by Lee1892: "; Combin_Final(m, n)
Next
End Sub
Function Combin_1(ByVal m&, ByVal n&)
Dim i&, j&, k&, tms!
tms = Timer
ReDim a&(1 To n)
For j = 1 To n - 1
a(j) = j
Next
k = 0: i = n - 1 ': j = n
Do
For i = i + 1 To m
'a(j) = i
k = k + 1
Next
For j = j - 1 To 1 Step -1
i = a(j) + 1: a(j) = i
If i = m - n + j Then
k = k + 1
Else
j = j + 1
Do Until j = n
i = i + 1: a(j) = i: j = j + 1
Loop
If i = m Then Exit Do Else Exit For
End If
Next
Loop Until j = 0
Erase a
Combin_1 = Format(Timer - tms, "0.000s ") & k
End Function
Function Combin_2(ByVal m&, ByVal n&)
Dim i&, j&, k&, tms!, p&
tms = Timer
ReDim a&(1 To n)
For j = 1 To n ' - 1
a(j) = j
Next
k = 0: i = n - 1: j = n
Do
For i = i + 1 To m
'a(n) = i
k = k + 1
Next
For j = j - 1 To 1 Step -1
i = a(j) + 1: a(j) = i
If i = m - n + j Then
k = k + 1
Else
'j = j + 1
'Do Until j = n
For p = j + 1 To n - 1
i = i + 1: a(p) = i ': j = j + 1
Next
'Loop
j = n
If i = m Then Exit Do Else Exit For
End If
Next
Loop Until j = 0
Erase a
Combin_2 = Format(Timer - tms, "0.000s ") & k
End Function
Function Combin_3(ByVal m&, ByVal n&)
Dim i&, j&, k&, tms!, p&
tms = Timer
ReDim a&(1 To n)
For j = 1 To n
a(j) = j
Next
'k = 0: i = n - 1: j = n
If m = n Then
k = 1
GoTo EXIT_FUNC
End If
i = n - 1
Do
For i = i + 1 To m
'a(n) = i
k = k + 1
Next
'For j = j - 1 To 1 Step -1
For j = n - 1 To 1 Step -1
i = a(j) + 1: a(j) = i
If i = m - n + j Then
k = k + 1
Else
'j = j + 1
'Do Until j = n
For p = j + 1 To n - 1
i = i + 1: a(p) = i ': j = j + 1
Next
'Loop
'If i = m Then Exit Do Else Exit For
Exit For
End If
Next
Loop Until j = 0
EXIT_FUNC:
Erase a
Combin_3 = Format(Timer - tms, "0.000s ") & k
End Function
Function Combin_4(ByVal m&, ByVal n&)
Dim i&, j&, k&, tms!, p&
tms = Timer
ReDim a&(1 To n)
For j = 1 To n
a(j) = j
Next
If m = n Then
k = 1
GoTo EXIT_FUNC
End If
'k = 0: i = n - 1: j = n
'Do
'For i = i + 1 To m
For i = n To m
'a(n) = i
k = k + 1
Next
'For j = j - 1 To 1 Step -1
For j = n - 1 To 1 Step -1
i = a(j) + 1: a(j) = i
If i = m - n + j Then
k = k + 1
Else
'j = j + 1
'Do Until j = n
For p = j + 1 To n - 1
i = i + 1: a(p) = i ': j = j + 1
Next
'Loop
For i = i + 1 To m
'a(n) = i
k = k + 1
Next
j = n
'If i = m Then Exit Do Else Exit For
End If
Next
'Loop Until j = 0
EXIT_FUNC:
Erase a
Combin_4 = Format(Timer - tms, "0.000s ") & k
End Function
Function Combin_Final(ItemCount As Long, Number As Long)
Dim i&, j&, nInd&, nCombCnt&, aComb&(), rTime!
rTime = Timer
If ItemCount < 0 Then Err.Raise 30001
If Number < 0 Then Err.Raise 30002
If Number > ItemCount Then Err.Raise 30003
If Number = 0 Then
nCombCnt = 1
GoTo EXIT_FUNC
End If
ReDim aComb(1 To Number)
For i = 1 To Number
aComb(i) = i
Next
If ItemCount = Number Then
nCombCnt = 1
GoTo EXIT_FUNC
End If
For i = Number To ItemCount
'aComb(Number) = i
nCombCnt = nCombCnt + 1
'Output combination here
Next
For i = Number - 1 To 1 Step -1
nInd = aComb(i) + 1
aComb(i) = nInd
If nInd = ItemCount - Number + i Then
nCombCnt = nCombCnt + 1
'Output combination here
Else
For j = i + 1 To Number - 1
nInd = nInd + 1
aComb(j) = nInd
Next
For nInd = nInd + 1 To ItemCount
'aComb(Number) = nInd
nCombCnt = nCombCnt + 1
'Output combination here
Next
i = Number
End If
Next
EXIT_FUNC:
Erase aComb
Combin_Final = Format(Timer - rTime, "0.000s ") & nCombCnt
End Function

复制代码

香川群子 · 发表于 2014-12-19 11:13

lee1892 发表于 2014-12-19 10:37
51 楼代码改进后的效果，由2.1秒加速到1.6秒不到，20%+代码改进的过程如下：

看明白了……把升序过程又进一步细化处理了。

我原来是2个地方有输出组合结果，你现在是3个地方输出结果了。

呵呵。

香川群子 · 发表于 2014-12-19 13:38

lee1892 发表于 2014-12-19 10:37
51 楼代码改进后的效果，由2.1秒加速到1.6秒不到，20%+代码改进的过程如下：

呵呵，还不是最终版。

根据你的思路我又改了改，速度更快！

变量名简化版

Function Combin_6(m&, n&)
If n >= m Or n < 2 Then Exit Function
Dim i&, j&, j2&, k&, tms#
tms = Timer
ReDim a&(1 To n), b&(1 To n)
For j = 1 To n - 1
a(j) = j: b(j) = m - n + j
Next
a(n - 1) = n - 2
For j = n - 1 To 1 Step -1
i = a(j) + 1: a(j) = i
If i = b(j) Then
k = k + 1 'Output
Else
For j2 = j + 1 To n - 1
i = i + 1: a(j2) = i
Next
j = n
For i = i + 1 To m
' a(n) = i
k = k + 1 'Output
Next
End If
Next
Combin_6 = Format(Timer - tms, "0.000s ") & k
End Function

复制代码

下面是变量名英文简要版(这个就是所谓自文档化？！)
我看着字母多就觉得还是麻烦。

Function Combin_7(m_ItemCount&, n_CombinNumber&) 'by kagawa 2014/12/19
If n_CombinNumber >= m_ItemCount Or n_CombinNumber < 2 Then Exit Function
Dim i_CombinValue&, j_DownIndex&, j2_UpIndex&, k_CombinCount&, tms#
tms = Timer
ReDim a_Value&(1 To n_CombinNumber), b_Limit&(1 To n_CombinNumber)
For j_DownIndex = 1 To n_CombinNumber - 1
a_Value(j_DownIndex) = j_DownIndex
b_Limit(j_DownIndex) = m_ItemCount - n_CombinNumber + j_DownIndex
Next
a_Value(n_CombinNumber - 1) = n_CombinNumber - 2
For j_DownIndex = n_CombinNumber - 1 To 1 Step -1
i_CombinValue = a_Value(j_DownIndex) + 1
a_Value(j_DownIndex) = i_CombinValue
If i_CombinValue = b_Limit(j_DownIndex) Then
k_CombinCount = k_CombinCount + 1 'Output Here while Last_IndexValue=LimitValue
Else
For j2_UpIndex = j_DownIndex + 1 To n_CombinNumber - 1
i_CombinValue = i_CombinValue + 1
a_Value(j2_UpIndex) = i_CombinValue
Next
j_DownIndex = n_CombinNumber
For i_CombinValue = i_CombinValue + 1 To m_ItemCount
' a_Value(n_CombinNumber) = i_CombinValue
k_CombinCount = k_CombinCount + 1 'Output Here while End_IndexValue Change
Next
End If
Next
Combin_7 = Format(Timer - tms, "0.000s ") & k_CombinCount
End Function

复制代码

最后，是汉字说明的变量自文档化：

Function Combin_8(m組合元素個数&, n組合抽取数&)
If n組合抽取数 >= m組合元素個数 Or n組合抽取数 < 2 Then Exit Function
Dim i組合値&, j組合位置降序&, j1組合位置昇序&, k組合計数&, tms#
tms = Timer
ReDim a組合値記録&(1 To n組合抽取数), b組合値上限&(1 To n組合抽取数)
For j1組合位置昇序 = 1 To n組合抽取数 - 1
a組合値記録(j1組合位置昇序) = j1組合位置昇序
b組合値上限(j1組合位置昇序) = m組合元素個数 - n組合抽取数 + j1組合位置昇序
Next
a組合値記録(n組合抽取数 - 1) = n組合抽取数 - 2
For j組合位置降序 = n組合抽取数 - 1 To 1 Step -1
i組合値 = a組合値記録(j組合位置降序) + 1
a組合値記録(j組合位置降序) = i組合値
If i組合値 = b組合値上限(j組合位置降序) Then
k組合計数 = k組合計数 + 1 'Output
Else
For j1組合位置昇序 = j組合位置降序 + 1 To n組合抽取数 - 1
i組合値 = i組合値 + 1
a組合値記録(j1組合位置昇序) = i組合値
Next
j組合位置降序 = n組合抽取数
For i組合値 = i組合値 + 1 To m組合元素個数
' a組合値記録(n組合抽取数) = i組合値
k組合計数 = k組合計数 + 1 'Output
Next
End If
Next
Combin_8 = Format(Timer - tms, "0.000s ") & k組合計数
End Function

复制代码

香川群子 · 发表于 2014-12-19 15:45

本帖最后由香川群子于 2014-12-19 15:57 编辑

lee1892 发表于 2014-12-19 10:37
51 楼代码改进后的效果，由2.1秒加速到1.6秒不到，20%+代码改进的过程如下：

【llee1892 新加的这个数组b不见得能有多大好处，期望的好处是减少了加减的计算，但坏处是增加了额外的变量询址。循环体内增加一个变量都会带来速度下降的影响。发表于 2014-12-19 13:59】

那好，这样改一下：

Function Combin_6(m&, n&)
If n >= m Or n < 2 Then Exit Function
Dim i&, i2&, j&, j2&, k&, tms#
tms = Timer
ReDim a&(1 To n)
For j = 1 To n - 1
a(j) = j: b(j) = m - n + j
Next
a(n - 1) = n - 2
i2 = m - 1
For j = n - 1 To 1 Step -1
i = a(j) + 1: a(j) = i
If i = i2 Then ' i2 = m - n + j
k = k + 1 'Output
i2 = i2 - 1
Else
For j2 = j + 1 To n - 1
i = i + 1: a(j2) = i
Next
j = n: i2 = m - 1
For i = i + 1 To m
' a(n) = i
k = k + 1 'Output
Next
End If
Next
Combin_6 = Format(Timer - tms, "0.000s ") & k
End Function

复制代码

增加一个【组合上限值指针 i2】或【i2_CombinMaxValue】或【i2組合値上限】

…………
可是比较发现，还是用数组b记录上限指针的方法速度更快一些。

lee1892 · 发表于 2014-12-19 17:08

香川群子发表于 2014-12-19 15:45
【llee1892 新加的这个数组b不见得能有多大好处，期望的好处是减少了加减的计算，但坏处是增加了额外的变 ...

我觉得这些都是小改动了，倒是如果C(m,n)算已知条件的前提下，改成 For i=1 to C(m,n)...Next这样的结构很可能会提速

EXCEL江湖 · 发表于 2014-12-19 19:53

香川群子发表于 2013-9-17 16:42
组合算法的汇总

研究学习当中，当组合数据量大时，输出会出错呀，如果数据量稍大点，内存是不是也会不够用，这是不是在做排列组合最大的问题！

laoau132 · 发表于 2015-4-15 09:58

提示: 作者被禁止或删除内容自动屏蔽

longe1013 · 发表于 2016-6-16 15:16

香川老师能不能帮我看看这个多列组合的例子怎么实现？
http://club.excelhome.net/thread-1284069-1-1.html

adequateboy · 发表于 2016-12-3 23:20

最近在筛选满足要求的组合，问题很多，可否指教

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

[分享] 求排列组合结果的自定义函数

点评

点评

点评

laoau132 laoau132 当前离线性别保密 UID 3029046 阅读权限 0 注册时间 2015-3-18 在线时间小时最后登录 1970-1-1 积分 743 财富分享技术精华头像被屏蔽 TA的精华主题 TA的得分主题	发表于 2015-4-15 09:58 \| 显示全部楼层 [广告] ★Excel Home云课堂 - 专业的职场技能充电站★ ★Excel三大利器★ ★ 笨办法学VBA全系列★ 提示: 作者被禁止或删除内容自动屏蔽

	回复举报