当前位置：首页 > news >正文

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

news 2025/7/8 0:20:01

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 VariantDim ribbon As IRibbonUItn = 0For i = 1 To 20000If datamp4(i, 1) = "" And datamp4(i, 2) = "" Then'Call ProcessBarUpdater(20000, 20000, "正在处理")Exit ForEnd IfIf datamp4(i, 1) = "" And datamp4(i, 2) <> "" Thentn = tn + 1End IfNexttnn = 0jd = TrueFor i = 1 To 20000If datamp4(i, 1) = "" And datamp4(i, 2) = "" ThenExit ForEnd IfIf datamp4(i, 1) = "" And datamp4(i, 2) <> "" Thentnn = tnn + 1'------处理条件，生成条件二维数组------For j = 2 To 25If InStr(datamp4(i, j), ";") > 0 Or InStr(datamp4(i, j), "~") > 0 ThenIf InStr(datamp4(i, j), ";") > 0 ThenIf InStr(datamp4(i, j), "~") > 0 Then'情况1含波浪号和波浪号n = 0For ni = 0 To UBound(Split(datamp4(i, j), ";"))If InStr(Split(datamp4(i, j), ";")(ni), "~") > 0 ThenFor 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) = nnn = n + 1Nextdatamp5(j - 2, n) = Split(Split(Split(datamp4(i, j), ";")(ni), "~")(1), "(")(0)n = n + 1Elsedatamp5(j - 2, n) = Split(datamp4(i, j), ";")(ni)n = n + 1End IfNextElse'情况2只含分号For n = 0 To UBound(Split(datamp4(i, j), ";")) '从情况2和情况3理解情况1datamp5(j - 2, n) = Split(datamp4(i, j), ";")(n)NextEnd IfElse'情况3只含波浪号If InStr(datamp4(i, j), "~") > 0 Thenn = 0For 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) = nin = n + 1Nextdatamp5(j - 2, n) = Split(Split(datamp4(i, j), "~")(1), "(")(0)End IfEnd IfElsedatamp5(j - 2, 0) = datamp4(i, j)End IfNext'------处理条件，生成条件二维数组------'------计算数据量------tn = 1For li = 0 To 50 'li为条件个数，lj为每个条件的选项个数If datamp5(li, 0) <> "" ThenFor lj = 0 To 2000If datamp5(li, lj) = "" ThenExit ForElse'Debug.Print datamp5(li, lj)End IfNexttn = tn * ljEnd IfNext'Debug.Print tn'------计算数据量------'------二维数组转为一维排列组合------For li = 0 To 50 'li为条件个数If datamp5(li, 0) <> "" ThenFor lj = 0 To 2000If datamp5(li, lj) = "" ThenExit ForEnd IfNext'Debug.Print lj 'lj为每个条件的选项个数If li = 0 ThenFor jj = 0 To lj - 1If datamp5(0, jj) <> "" Thendatamp6(jj, 0) = datamp5(0, jj) '赋值给数组ElseExit ForEnd IfNext'Debug.Print jj’第一个条件的情况数Else'Debug.Print "-----------"If li = 1 ThenFor ii = 0 To 10000 '每个条件开始前计算已有的情况个数对应的行数If datamp6(ii, 0) = "" ThenExit ForEnd IfNextElseIf n = 0 ThenFor ii = 0 To 10000 '每个条件开始前计算已有的情况个数对应的行数If datamp6(ii, 0) = "" ThenExit ForEnd IfNextElseii = n 'End IfEnd If'Debug.Print "ii=" & iin = 0For 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 IfElse'第i个取datamp5的值datamp6(n, nj) = datamp5(li, mi)'                                If i < 7 Then'                                    Debug.Print n & ";" & i'                                End If'Debug.Print datamp5(i, mi)End IfIf li = 7 Then'Debug.Print n & "," & nj & "=" & datamp6(n, nj)End IfNextIf lj - 1 > 0 Or ii - 1 > 0 Thenn = n + 1End IfNextNextEnd IfElseExit ForEnd If'Debug.Print "n=" & nNextApplication.ScreenUpdating = Falseni = Sheets("扭矩查询").Range("a" & Rows.Count).End(xlUp).Row + 1For li = 0 To 1000000If datamp6(li, 0) <> "" ThenFor j = 0 To 20'Debug.Print i & "," & j & "=" & datamp6(i, j)Sheets("扭矩查询").Cells(ni + li, j + 1) = datamp6(li, j)NextElseExit ForEnd IfNext'------二维数组转为一维排列组合------Sheets(sht_name).Cells(i, 1) = TrueFor t = 1 To 25If datamp4(1, t) = "" ThenFor ti = t + 1 To 26If datamp4(i, ti) = "" ThenSheets(sht_name).Cells(i, ti) = Format(Now(), "YYYY/MM/DD hh:mm")Exit ForEnd IfNextExit ForEnd IfNextErase datamp5Erase datamp6Application.ScreenUpdating = TrueEnd IfIf tnn <> 0 And jd = True Then'Debug.Print tnn & ";" & tnCall ProcessBarUpdater(tnn, tn, "正在处理")End IfIf tnn = tn Thenjd = FalseEnd IfNextFor i = 0 To 50 '打印For j = 0 To 500If datamp5(i, j) <> "" Then'Debug.Print i & ";" & j & "=" & datamp5(i, j)ElseExit ForEnd IfNextNextErase datamp4
End Sub