VBA实战(Excel)(5)：介绍一种排列组合算法

1. 需求场景

有多个条件，条件个数不定，每个条件有若干种情况，情况个数不定，输出所有条件可能的情况的排列组合。

2.举例

假设第一次有5个情况要填，第一个条件20种情况，第二个5种，第三个40种，第四个10种，第五个4种。那么共要输出条件数=20x5x40x10x4=160000种，第二次可能要输出30万钟，等等……

3.实现程序

Sub getalldata(control As Office.IRibbonControl) '生成
sht_name = Sheets("参数").Cells(2, 2)
datamp4 = Sheets(sht_name).Range("A1:Z20000")
Dim datamp5(50, 2000) As String 'datamp5存储批量条件数据
Dim datamp6(1000000, 20) As Variant
Dim ribbon As IRibbonUI
tn = 0
For i = 1 To 20000
If datamp4(i, 1) = "" And datamp4(i, 2) = "" Then
'Call ProcessBarUpdater(20000, 20000, "正在处理")
Exit For
End If
If datamp4(i, 1) = "" And datamp4(i, 2)  "" Then
tn = tn + 1
End If
Next
tnn = 0
jd = True
For i = 1 To 20000
If datamp4(i, 1) = "" And datamp4(i, 2) = "" Then
Exit For
End If
If datamp4(i, 1) = "" And datamp4(i, 2)  "" Then
tnn = tnn + 1
'------处理条件，生成条件二维数组------
For j = 2 To 25
If InStr(datamp4(i, j), ";") > 0 Or InStr(datamp4(i, j), "~") > 0 Then
If InStr(datamp4(i, j), ";") > 0 Then
If InStr(datamp4(i, j), "~") > 0 Then
'情况1含波浪号和波浪号
n = 0
For ni = 0 To UBound(Split(datamp4(i, j), ";"))
If InStr(Split(datamp4(i, j), ";")(ni), "~") > 0 Then
For nn = Split(Split(datamp4(i, j), ";")(ni), "~")(0) To Split(Split(Split(datamp4(i, j), ";")(ni), "~")(1), "(")(0) Step Replace(Split(Split(Split(datamp4(i, j), ";")(ni), "~")(1), "(")(1), ")", "")
datamp5(j - 2, n) = nn
n = n + 1
Next
datamp5(j - 2, n) = Split(Split(Split(datamp4(i, j), ";")(ni), "~")(1), "(")(0)
n = n + 1
Else
datamp5(j - 2, n) = Split(datamp4(i, j), ";")(ni)
n = n + 1
End If
Next
Else
'情况2只含分号
For n = 0 To UBound(Split(datamp4(i, j), ";")) '从情况2和情况3理解情况1
datamp5(j - 2, n) = Split(datamp4(i, j), ";")(n)
Next
End If
Else
'情况3只含波浪号
If InStr(datamp4(i, j), "~") > 0 Then
n = 0
For ni = Split(datamp4(i, j), "~")(0) To Split(Split(datamp4(i, j), "~")(1), "(")(0) Step Replace(Split(Split(datamp4(i, j), "~")(1), "(")(1), ")", "")
datamp5(j - 2, n) = ni
n = n + 1
Next
datamp5(j - 2, n) = Split(Split(datamp4(i, j), "~")(1), "(")(0)
End If
End If
Else
datamp5(j - 2, 0) = datamp4(i, j)
End If
Next
'------处理条件，生成条件二维数组------
'------计算数据量------
tn = 1
For li = 0 To 50 'li为条件个数，lj为每个条件的选项个数
If datamp5(li, 0)  "" Then
For lj = 0 To 2000
If datamp5(li, lj) = "" Then
Exit For
Else
'Debug.Print datamp5(li, lj)
End If
Next
tn = tn * lj
End If
Next
'Debug.Print tn
'------计算数据量------
'------二维数组转为一维排列组合------
For li = 0 To 50 'li为条件个数
If datamp5(li, 0)  "" Then
For lj = 0 To 2000
If datamp5(li, lj) = "" Then
Exit For
End If
Next
'Debug.Print lj 'lj为每个条件的选项个数
If li = 0 Then
For jj = 0 To lj - 1
If datamp5(0, jj)  "" Then
datamp6(jj, 0) = datamp5(0, jj) '赋值给数组
Else
Exit For
End If
Next
'Debug.Print jj’第一个条件的情况数
Else
'Debug.Print "-----------"
If li = 1 Then
For ii = 0 To 10000 '每个条件开始前计算已有的情况个数对应的行数
If datamp6(ii, 0) = "" Then
Exit For
End If
Next
Else
If n = 0 Then
For ii = 0 To 10000 '每个条件开始前计算已有的情况个数对应的行数
If datamp6(ii, 0) = "" Then
Exit For
End If
Next
Else
ii = n '
End If
End If
'Debug.Print "ii=" & ii
n = 0
For mi = 0 To lj - 1 'datamp5第i个条件的选项个数
For ni = 0 To ii - 1 'datamp6数组的行数
For nj = 0 To li 'datamp6数组的列数
If nj < li Then
'第i之前直接复制
datamp6(n, nj) = datamp6(ni, nj)
'                                If i < 7 Then
'                                    Debug.Print n & ";" & ni & ";" & nj
'                                End If
Else
'第i个取datamp5的值
datamp6(n, nj) = datamp5(li, mi)
'                                If i  0 Or ii - 1 > 0 Then
n = n + 1
End If
Next
Next
End If
Else
Exit For
End If
'Debug.Print "n=" & n
Next
Application.ScreenUpdating = False
ni = Sheets("扭矩查询").Range("a" & Rows.Count).End(xlUp).Row + 1
For li = 0 To 1000000
If datamp6(li, 0)  "" Then
For j = 0 To 20
'Debug.Print i & "," & j & "=" & datamp6(i, j)
Sheets("扭矩查询").Cells(ni + li, j + 1) = datamp6(li, j)
Next
Else
Exit For
End If
Next
'------二维数组转为一维排列组合------
Sheets(sht_name).Cells(i, 1) = True
For t = 1 To 25
If datamp4(1, t) = "" Then
For ti = t + 1 To 26
If datamp4(i, ti) = "" Then
Sheets(sht_name).Cells(i, ti) = Format(Now(), "YYYY/MM/DD hh:mm")
Exit For
End If
Next
Exit For
End If
Next
Erase datamp5
Erase datamp6
Application.ScreenUpdating = True
End If
If tnn  0 And jd = True Then
'Debug.Print tnn & ";" & tn
Call ProcessBarUpdater(tnn, tn, "正在处理")
End If
If tnn = tn Then
jd = False
End If
Next
For i = 0 To 50 '打印
For j = 0 To 500
If datamp5(i, j)  "" Then
'Debug.Print i & ";" & j & "=" & datamp5(i, j)
Else
Exit For
End If
Next
Next
Erase datamp4
End Sub

4. 算法思路讲解

4.1先把条件列转为二维数组，可以得出当前有多少个条件，每个条件多少种情况。

4.2把条件二维数组的第一行（第一种排列组合）赋值给“排列组合”二维数组，此时二维数组只有一行

4.3从“排列组合”一维数组的第一位开始，第一个条件有n种情况，就循环n次赋值，每次只变一位，其他位复制，第二个条件同理，以此类推。

5. 应用实例

此实例涉及商业保密，不便上传文件，想要演示实例，请私信博主。