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

lin505 · 发表于 2013-8-19 14:32

{:soso_e196:}膜拜膜拜

lin505 · 发表于 2013-8-19 14:40

http://club.excelhome.net/thread-1047617-1-1.html
大师能不能帮我这个排一下？

龙游小巧 · 发表于 2013-8-20 14:35

{:soso_e182:}

香川群子 · 发表于 2013-8-20 14:54

lin505 发表于 2013-8-19 14:40
http://club.excelhome.net/thread-1047617-1-1.html
大师能不能帮我这个排一下？

这个用递归剪枝法计算，比循环计算全部组合的算法，效率高的多。

已在你的原帖中给予解答。

香川群子 · 发表于 2013-8-23 16:39

顺便把排列算法也做了些改进……但尚未全部完成。

香川群子 · 发表于 2013-8-24 18:25

这个已经是目前最快的排列代码了：

Sub GetPermut_Mid1()
Dim i&, j&, k&, l&, m&, n&, s$
m = [a1].End(4).Row: sj = [a1].Resize(m): n = [b1]
tms = Timer
k = Application.Permut(m, n)
ReDim jg1$(1 To k, 1 To 1)
For j = 1 To m
If Len(sj(j, 1)) > l Then l = Len(sj(j, 1))
Next
ReDim sj1$(1 To m)
s = String(l, " ")
For j = 1 To m
sj1(j) = Right(s & sj(j, 1), l)
Next
ReDim a&(n)
ReDim b&(1 To m)
s = ""
For j = 1 To n - 1
a(j) = j
b(j) = 1
s = s & sj1(j)
Next
s = s & sj1(j)
i = n - 1: r = m - i: k = 0 ':j = n
Do
Do
i = i + 1
If b(i) = 0 Then a(j) = i: b(i) = 1: r = r - 1: Exit Do
Loop
Mid(s, (j - 1) * l + 1, l) = sj1(i)
If j = n Then
k = k + 1: jg1(k, 1) = s
If r = 0 Then
Do
j = j - 1
If a(j) < m Then
ReDim b&(1 To m)
s = String(l * n, " ")
For j = 1 To j - 1
b(a(j)) = 1
Mid(s, (j - 1) * l + 1, l) = sj1(a(j))
Next
i = a(j)
Do While i < m
i = i + 1
If b(i) = 0 Then
a(j) = i: b(i) = 1
Mid(s, (j - 1) * l + 1, l) = sj1(i)
i = 0: r = m - j: j = j + 1
Exit Do
End If
Loop
If i = 0 Then Exit Do
End If
Loop Until j = 1
If j = 1 Then Exit Do
End If
Else
j = j + 1
i = 0
End If
Loop
[b11] = Format(Timer - tms, "0.000s PermutDo1 ") & k
If [c1] = "" And k < 65536 Then
tms = Timer: [d:d] = "": [d1].Resize(k) = jg1: [d1].EntireColumn.AutoFit
[b11] = [b11] & " " & Format(Timer - tms, "0.000s")
End If
Erase jg1
End Sub

复制代码

香川群子 · 发表于 2013-8-24 18:26

比组合复杂多了……

刚刚写完，或许还可以再做些优化、改进。

Function PermutDo(m&, n&)
Dim i&, j&, k&, l&
tms = Timer
ReDim a&(n)
ReDim b&(1 To m)
For j = 1 To n - 1
a(j) = j
b(j) = 1
Next
i = n - 1: r = m - i: k = 0 ':j = n
Do
Do
i = i + 1
If b(i) = 0 Then a(j) = i: b(i) = 1: r = r - 1: Exit Do
Loop
If j = n Then
k = k + 1
If r = 0 Then
Do
j = j - 1
If a(j) < m Then
ReDim b&(1 To m)
For j = 1 To j - 1
b(a(j)) = 1
Next
i = a(j)
Do While i < m
i = i + 1
If b(i) = 0 Then
a(j) = i: b(i) = 1
i = 0: r = m - j: j = j + 1
Exit Do
End If
Loop
If i = 0 Then Exit Do
End If
Loop Until j = 1
If j = 1 Then Exit Do
End If
Else
j = j + 1
i = 0
End If
Loop
PermutDo = Format(Timer - tms, "0.0000s ") & " kagawa Do2 Permut(" & m & "," & n & ")= " & k
End Function

复制代码

香川群子 · 发表于 2013-8-25 10:50

优化完成，速度又提高了一倍。

下面是速度函数

Function PermutDo(ByVal m&, ByVal n&)
Dim i&, j&, k&
tms = Timer
n = n - 1: ReDim a&(n)
ReDim b(1 To m) As Boolean
For j = 0 To n - 1
a(j) = 1 + j
b(1 + j) = True
Next
'i = 0: j = n: k = 0
Do
If j = n Then
For i = 1 To m
If Not b(i) Then
a(j) = i
k = k + 1
End If
Next
If n = 0 Then Exit Do
Do
j = j - 1
i = a(j): b(i) = False
For i = i + 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
i = 0: Exit Do
End If
Next
Loop Until j = 0
If i Then Exit Do
Else
j = j + 1
If j < n Then
For i = 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
Exit For
End If
Next
End If
End If
Loop
PermutDo = Format(Timer - tms, "0.0000s ") & " kagawa Do Permut(" & m & "," & n + 1 & ")= " & k
End Function

复制代码

下面是可输出排列结果的代码

Sub GetPermut_Mid()
Dim i&, j&, k&, l&, m&, n&, s$
tms = Timer
m = [a1].End(4).Row: sj = [a1].Resize(m): n = [b1]
k = Application.Permut(m, n)
ReDim jg1$(1 To k, 1 To 1): k = 0
For j = 1 To m
If Len(sj(j, 1)) > l Then l = Len(sj(j, 1))
Next
ReDim sj1$(1 To m)
s = String(l, " ")
For j = 1 To m
sj1(j) = Right(s & sj(j, 1), l)
Next
n = n - 1: ReDim a&(n)
ReDim b(1 To m) As Boolean
s = String(l * n + l, " ")
For j = 0 To n - 1
a(j) = 1 + j
b(1 + j) = True
Mid(s, j * l + 1, l) = sj1(1 + j)
Next
'i = 0: j = n: k = 0
Do
If j = n Then
For i = 1 To m
If Not b(i) Then
a(j) = i
Mid(s, j * l + 1, l) = sj1(i)
k = k + 1
jg1(k, 1) = s
End If
Next
If n = 0 Then Exit Do
' If s = "6543" Then Stop
Do
j = j - 1
i = a(j): b(i) = False
For i = i + 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
Mid(s, j * l + 1, l) = sj1(i)
i = 0
Exit Do
End If
Next
Loop Until j = 0
If i Then Exit Do
Else
j = j + 1
If j < n Then
For i = 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
Mid(s, j * l + 1, l) = sj1(i)
Exit For
End If
Next
End If
End If
Loop
[b14] = Format(Timer - tms, "0.000s PermutDo ") & k
If [c1] = "" And k < 65536 Then
tms = Timer: [h:h] = "": [h1].Resize(k) = jg1: [h1].EntireColumn.AutoFit
[b14] = [b14] & " " & Format(Timer - tms, "0.000s")
End If
Erase jg1
End Sub

复制代码

香川群子 · 发表于 2013-8-25 14:07

本帖最后由香川群子于 2013-8-25 14:34 编辑

继续改进：

Sub GetPermut_Mid6()
Dim i&, ii&, j&, k&, l&, m&, n&, s$
tms = Timer
m = [a1].End(4).Row: sj = [a1].Resize(m): n = [b1]
k = Application.Permut(m, n)
ReDim jg1$(1 To k, 1 To 1): k = 0
For j = 1 To m
If Len(sj(j, 1)) > l Then l = Len(sj(j, 1))
Next
ReDim sj1$(1 To m)
s = String(l, " ")
For j = 1 To m
sj1(j) = Right(s & sj(j, 1), l)
Next
n = n - 1: ReDim a&(n)
ReDim b(1 To m) As Boolean
s = String(l * n + l, " ")
For j = 0 To n - 1
a(j) = 1 + j
b(1 + j) = True
Mid(s, j * l + 1, l) = sj1(1 + j)
Next
'i = 0: j = n: k = 0
Do
For i = 1 To m
If Not b(i) Then
' a(j) = i
Mid(s, j * l + 1, l) = sj1(i)
k = k + 1
jg1(k, 1) = s
End If
Next
If n = 0 Then Exit Do
' If s = "6543" Then Stop
Do
j = j - 1: i = a(j): b(i) = False
For i = i + 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
Mid(s, j * l + 1, l) = sj1(i)
If j < n - 1 Then
i = 0
Do
i = i + 1
If Not b(i) Then
j = j + 1: a(j) = i: b(i) = True
Mid(s, j * l + 1, l) = sj1(i)
If j = n - 1 Then Exit Do
End If
Loop
End If
j = n: Exit Do
End If
Next
Loop Until j = 0
If j = 0 Then Exit Do
Loop
[b16] = Format(Timer - tms, "0.000s PermutDo6 ") & k
If [c1] = "" And k < 65536 Then
tms = Timer: [j:j] = "": [j1].Resize(k) = jg1: [j1].EntireColumn.AutoFit
[b16] = [b16] & " " & Format(Timer - tms, "0.000s")
End If
Erase jg1
End Sub

复制代码

香川群子 · 发表于 2013-8-27 21:19

Function PermutDo6(ByVal m&, ByVal n&)
Dim i&, j&, k&
tms = Timer
n = n - 1: ReDim a&(n)
ReDim b(1 To m) As Boolean
For j = 0 To n - 1
a(j) = 1 + j
b(1 + j) = True
Next
'i = 0: j = n: k = 0
Do
For i = 1 To m
If Not b(i) Then
' a(j) = i
k = k + 1
End If
Next
Do Until j = 0
j = j - 1: i = a(j): b(i) = False
For i = i + 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
If j < n - 1 Then
i = 0
Do
i = i + 1
If Not b(i) Then
j = j + 1: a(j) = i: b(i) = True
If j = n - 1 Then Exit Do
End If
Loop
End If
j = n: Exit Do
End If
Next
Loop
Loop Until j = 0
PermutDo6 = Format(Timer - tms, "0.0000s ") & " kagawa Do6 Permut(" & m & "," & n + 1 & ")= " & k
End Function
Function PermutDo5(ByVal m&, ByVal n&)
Dim i&, j&, k&
tms = Timer
n = n - 1: ReDim a&(n)
ReDim b(1 To m) As Boolean
For j = 0 To n - 1
a(j) = 1 + j
b(1 + j) = True
Next
'i = 0: j = n: k = 0
Do
For i = 1 To m
If Not b(i) Then
' a(j) = i
k = k + 1
End If
Next
Do Until j = 0
j = j - 1: i = a(j): b(i) = False
For i = i + 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
i = 0: Exit Do
End If
Next
Loop
If i Then Exit Do
For j = j + 1 To n - 1
For i = i + 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
Exit For
End If
Next
Next
Loop
PermutDo5 = Format(Timer - tms, "0.0000s ") & " kagawa Do5 Permut(" & m & "," & n + 1 & ")= " & k
End Function

复制代码

Sub GetPermut_Mid6()
Dim i&, ii&, j&, k&, l&, m&, n&, s$
tms = Timer
m = [a1].End(4).Row: sj = [a1].Resize(m): n = [b1]
k = Application.Permut(m, n)
ReDim jg1$(1 To k, 1 To 1): k = 0
For j = 1 To m
If Len(sj(j, 1)) > l Then l = Len(sj(j, 1))
Next
ReDim sj1$(1 To m)
s = String(l, " ")
For j = 1 To m
sj1(j) = Right(s & sj(j, 1), l)
Next
n = n - 1: ReDim a&(n)
ReDim b(1 To m) As Boolean
s = String(l * n + l, " ")
For j = 0 To n - 1
a(j) = 1 + j
b(1 + j) = True
Mid(s, j * l + 1, l) = sj1(1 + j)
Next
'i = 0: j = n: k = 0
Do
For i = 1 To m
If Not b(i) Then
' a(j) = i
Mid(s, j * l + 1, l) = sj1(i)
k = k + 1
jg1(k, 1) = s
End If
Next
If s = "6543" Then Stop
Do Until j = 0
j = j - 1: i = a(j): b(i) = False
For i = i + 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
Mid(s, j * l + 1, l) = sj1(i)
If j < n - 1 Then
i = 0
Do
i = i + 1
If Not b(i) Then
j = j + 1: a(j) = i: b(i) = True
Mid(s, j * l + 1, l) = sj1(i)
If j = n - 1 Then Exit Do
End If
Loop
End If
j = n: Exit Do
End If
Next
Loop
Loop Until j = 0
[b16] = Format(Timer - tms, "0.000s PermutDo6 ") & k
If [c1] = "" And k < 65536 Then
tms = Timer: [j:j] = "": [j1].Resize(k) = jg1: [j1].EntireColumn.AutoFit
[b16] = [b16] & " " & Format(Timer - tms, "0.000s")
End If
Erase jg1
End Sub
Sub GetPermut_Mid5()
Dim i&, ii&, j&, k&, l&, m&, n&, s$
tms = Timer
m = [a1].End(4).Row: sj = [a1].Resize(m): n = [b1]
k = Application.Permut(m, n)
ReDim jg1$(1 To k, 1 To 1): k = 0
For j = 1 To m
If Len(sj(j, 1)) > l Then l = Len(sj(j, 1))
Next
ReDim sj1$(1 To m)
s = String(l, " ")
For j = 1 To m
sj1(j) = Right(s & sj(j, 1), l)
Next
n = n - 1: ReDim a&(n)
ReDim b(1 To m) As Boolean
s = String(l * n + l, " ")
For j = 0 To n - 1
a(j) = 1 + j
b(1 + j) = True
Mid(s, j * l + 1, l) = sj1(1 + j)
Next
'i = 0: j = n: k = 0
Do
For i = 1 To m
If Not b(i) Then
' a(j) = i
Mid(s, j * l + 1, l) = sj1(i)
k = k + 1
jg1(k, 1) = s
End If
Next
' If s = "6543" Then Stop
Do Until j = 0
j = j - 1: i = a(j): b(i) = False
For i = i + 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
Mid(s, j * l + 1, l) = sj1(i)
i = 0: Exit Do
End If
Next
Loop
If i Then Exit Do
For j = j + 1 To n - 1
For i = i + 1 To m
If Not b(i) Then
a(j) = i: b(i) = True
Mid(s, j * l + 1, l) = sj1(i)
Exit For
End If
Next
Next
Loop
[b15] = Format(Timer - tms, "0.000s PermutDo5 ") & k
If [c1] = "" And k < 65536 Then
tms = Timer: [i:i] = "": [i1].Resize(k) = jg1: [i1].EntireColumn.AutoFit
[b15] = [b15] & " " & Format(Timer - tms, "0.000s")
End If
Erase jg1
End Sub

复制代码

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

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

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