Excel VBA在拾取一个组合而不放回后查找组合

我之前的问题在这里：。我现在想尝试更详细一点

我现在有一个这样的组合列表：

A
B
AB
C
AC
BC
ABC
D
广告
BD
CD
E
AE
是
行政长官

我想要一个新的宏来做的是获取这些信息，并找出选择所有字母有多少个选项。例如，选项1将导致：

A、B、C、D、E

AC B D E

等等

您选择一个框，并找出拥有所有框所需的可能性。这是我尝试过的另一个代码，但由于计算时间长，它的工作效果不太好：

Public Text, Alpha, Beta, Temp_Result, Temp_Stack, Wgt, Hgt, Stack, Stack_Sum
Public Max_Wgt As Double, Max_Hgt As Double, Crt_Wgt, Crt_Hgt, Next_Row As Long, Next_Col As Long
Sub ListCombinations()
    Dim Str_Len As Integer, Len_Text As Integer, TotalComb As Integer
    Len_Text = Worksheets("Sheet1").Range("A65536").End(xlUp).Row - 1
    Worksheets("Sheet2").Range("A2:IJ65536").Clear
    Next_Row = 1
    Next_Col = 1
    Stack = 0
    Max_Wgt = Worksheets("Limits").Range("B1")
    Max_Hgt = Worksheets("Limits").Range("B2")

    ReDim Alpha(1 To Len_Text)
    For j = 1 To Len_Text
            Alpha(j) = Worksheets("Sheet1").Cells(j + 1, 1)
    Next j

    For i = 1 To Len_Text
        Str_Len = i



        ReDim Temp_Result(1 To Str_Len)



        AddCombination Len_Text, Str_Len


    Next i
    Find_Stacks
End Sub


Private Sub AddCombination(Optional PopSize As Integer = 0, _
                          Optional SetSize As Integer = 0, _
                          Optional NextMember As Integer = 0, _
                          Optional NextItem As Integer = 0)

Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Dim i As Integer

If PopSize <> 0 Then
    iPopSize = PopSize
    iSetSize = SetSize
    ReDim SetMembers(1 To iSetSize) As Integer
    ReDim Crt_Wgt(1 To iSetSize) As Double
    ReDim Crt_Hgt(1 To iSetSize) As Double
    NextMember = 1
    NextItem = 1
End If

For i = NextItem To iPopSize
    SetMembers(NextMember) = i
    Crt_Wgt(NextMember) = Worksheets("Sheet1").Cells(i + 1, 2)
    Crt_Hgt(NextMember) = Worksheets("Sheet1").Cells(i + 1, 3)
    If NextMember <> iSetSize Then
        AddCombination , , NextMember + 1, i + 1
    Else
        If (Application.WorksheetFunction.sum(Crt_Wgt) > Max_Wgt) Or _
            (Application.WorksheetFunction.sum(Crt_Hgt) > Max_Hgt) Then

        Else
            If Stack = 0 Then
                SavePermutation SetMembers(), iSetSize
            Else
                SaveStack SetMembers(), iSetSize
            End If

        End If
    End If
Next i



End Sub 'AddCombination

Sub SavePermutation(Set_Member, Str_Len As Integer)
For i = 1 To Str_Len
    Temp_Result(i) = Alpha(Set_Member(i))
Next i

If Next_Row > 65535 Then
    Next_Row = 1
    Next_Col = Next_Col + 4
End If

Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col) = Join(Temp_Result, "")  Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col + 1) = Application.WorksheetFunction.sum(Crt_Wgt)
Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col + 2) = Application.WorksheetFunction.sum(Crt_Hgt)
Action = Find_Number()
Next_Row = Next_Row + 1

End Sub


Function Find_Number()
    Text = Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col)
    Sum_Char = 0
    For i = 1 To Len(Text)
        iChar = Left(Text, 1)
        Sum_Char = Sum_Char + Worksheets("Sheet1").Cells(WorksheetFunction.Match(iChar, Worksheets("Sheet1").Range("A:A"), 0), 4)
        Text = Right(Text, Len(Text) - 1)
    Next i
    Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col + 3) = Sum_Char
End Function

Sub Find_Stacks()
Dim Len_Text As Integer, Str_Len As Integer
Stack_Sum = WorksheetFunction.sum(Worksheets("Sheet1").Range("D:D"))
Len_Text = Worksheets("Sheet2").Range("D65536").End(xlUp).Row - 1
Stack = 1
Next_Row = 1
ReDim Alpha(1 To Len_Text)
ReDim Beta(1 To Len_Text)
For j = 1 To Len_Text
    Alpha(j) = Worksheets("Sheet2").Cells(j + 1, 1)
    Beta(j) = Worksheets("Sheet2").Cells(j + 1, 4)
Next j
Worksheets("Sheet4").Range("A1:B65536").Clear
For i = 2 To Len_Text
    Str_Len = i
    ReDim Temp_Result(1 To Str_Len)
    ReDim Temp_Stack(1 To Str_Len)
    AddCombination Len_Text, Str_Len
Next i
End Sub

Sub SaveStack(Set_Member, Str_Len As Integer)
    For i = 1 To Str_Len
        Temp_Result(i) = Alpha(Set_Member(i))
        Temp_Stack(i) = Beta(Set_Member(i))
    Next i
    If (Application.WorksheetFunction.sum(Temp_Stack) = Stack_Sum) Then
        Crt_Text = Join(Temp_Result, "")
        Len_Char = Len(Crt_Text)
        For i = 1 To Len_Char
            Crt_Char = InStr(2, Crt_Text, Left(Crt_Text, 1))
            If (Crt_Char > 1) Then
                GoTo End_Loop
            End If
            Crt_Text = Right(Crt_Text, Len(Crt_Text) - 1)
        Next i
        Worksheets("Sheet4").Cells(Next_Row + 1, 1) = Join(Temp_Result, ",")
        Next_Row = Next_Row + 1
    End If
End_Loop:
End Sub

公共文本、Alpha、Beta、Temp_结果、Temp_堆栈、Wgt、Hgt、堆栈、堆栈和
公共最大Wgt为双精度，最大Hgt为双精度，Crt为Wgt，Crt为Hgt，下一行为长，下一列为长
子列表组合（）
Dim Str_Len为整数，Len_Text为整数，TotalComb为整数
Len_Text=工作表（“表1”）。范围（“A65536”）。结束（xlUp）。第1行
工作表（“表2”）。范围（“A2:IJ65536”）。清除
下一行=1
下一列=1
堆栈=0
最大Wgt=工作表（“限制”）。范围（“B1”）
最大值=工作表（“限制”）。范围（“B2”）
重播Alpha（1到Len_文本）
对于j=1到Len_文本
α（j）=工作表（“表1”）。单元格（j+1，1）
下一个j
对于i=1到Len_文本
Str_Len=i
ReDim临时结果（1至Str）
添加组合Len_文本，Str_Len
接下来我
查找\u堆栈
端接头
私有子AddCombination（可选PopSize为整数=0_
可选设置大小为整数=0_
可选的下一个成员为整数=0_
可选的NextItem（整数=0）
静态iPopSize为整数
静态iSetSize为整数
静态SetMembers（）为整数
作为整数的Dim i
如果大小为0，则
iPopSize=PopSize
iSetSize=设置大小
将SetMembers（1到iSetSize）重拨为整数
将Crt_Wgt（1到iSetSize）重拨为双精度
将Crt_Hgt（1到iSetSize）重拨为双精度
下一个成员=1
NextItem=1
如果结束
对于i=NextItem进行iPopSize
集合成员（下一个成员）=i
Crt_Wgt（下一个成员）=工作表（“表1”）。单元格（i+1,2）
Crt_Hgt（下一个成员）=工作表（“表1”）。单元格（i+1,3）
如果NextMember为大小，则
添加组合，下一个成员+1，i+1
其他的
If（Application.WorksheetFunction.sum（Crt\u Wgt）>Max\u Wgt）或_
（Application.WorksheetFunction.sum（Crt\u Hgt）>Max\u Hgt）然后
其他的
如果Stack=0，则
SavePermutation SetMembers（），iSetSize
其他的
SaveStack SetMembers（），iSetSize
如果结束
如果结束
如果结束
接下来我
“结束子”添加组合
子存储置换（集合成员，字符串为整数）
对于i=1到Str_Len
临时结果（i）=α（集合成员（i））
接下来我
如果下一行>65535，则
下一行=1
下一列=下一列+4
如果结束
工作表（“Sheet2”）。单元格（下一行+1，下一列）=连接（临时结果“）。工作表（“Sheet2”）。单元格（下一行+1，下一列+1）=应用程序。工作表函数。总和（Crt\U Wgt）
工作表（“Sheet2”）.Cells（下一行+1，下一列+2）=Application.WorksheetFunction.sum（Crt\U Hgt）
动作=查找编号（）
下一行=下一行+1
端接头
函数Find_Number（）
Text=工作表（“Sheet2”）.单元格（下一行+1，下一列）
Sum_Char=0
对于i=1到Len（文本）
iChar=左（文本，1）
Sum_Char=Sum_Char+工作表（“Sheet1”）.单元格（工作表函数.Match（iChar，工作表（“Sheet1”）.范围（“A:A”），0），4）
Text=右（Text，Len（Text）-1）
接下来我
工作表（“表2”）。单元格（下一行+1，下一列+3）=和字符
端函数
子查找_堆栈（）
Dim Len_文本为整数，Str_Len为整数
Stack_Sum=工作表函数.Sum（工作表（“Sheet1”）.范围（“D:D”））
Len_Text=工作表（“表2”）。范围（“D65536”）。结束（xlUp）。第1行
堆栈=1
下一行=1
重播Alpha（1到Len_文本）
ReDim Beta（1至Len_文本）
对于j=1到Len_文本
α（j）=工作表（“表2”）。单元格（j+1，1）
Beta（j）=工作表（“表2”）。单元格（j+1,4）
下一个j
工作表（“表4”）。范围（“A1:B65536”）。清除
对于i=2到Len_文本
Str_Len=i
ReDim临时结果（1至Str）
ReDim临时堆栈（1至Str）
添加组合Len_文本，Str_Len
接下来我
端接头
子存储堆栈（将\u成员、Str\u Len设置为整数）
对于i=1到Str_Len
临时结果（i）=α（集合成员（i））
临时堆栈（i）=β（集合成员（i））
接下来我
如果（Application.WorksheetFunction.sum（Temp\u Stack）=Stack\u sum），则
Crt_Text=Join（临时结果“”）
Len_Char=Len（Crt_文本）
对于i=1到Len_Char
Crt_Char=InStr（2，Crt_文本，左侧（Crt_文本，1））
如果（Crt_Char>1），则
转到结束循环
如果结束
Crt_Text=右（Crt_Text，Len（Crt_Text）-1）
接下来我
工作表（“Sheet4”）。单元格（下一行+1，1）=连接（临时结果，”）
下一行=下一行+1
如果结束
结束循环：
端接头

此代码我们在第1页的方框中有高度和重量，第2页应提供所有选项，第3页为限制，第4页为最终选项。这个有很长的执行时间。我想减少这个，有人能帮我吗

如果你需要更多的信息，请告诉我

---

编辑

这是另一个代码，它是否优于上面的代码？这是我上一个问题的结果。我只想知道哪一个更适合我使用。为了减少执行时间并向上面解释的最终结果宏迈进，请对齐所有可能的选项

Function stackBox()
    Dim ws As Worksheet
    Dim width As Long
    Dim height As Long
    Dim numOfBox As Long
    Dim optionsA() As Variant
    Dim results() As Variant
    Dim str As String
    Dim outputArray As Variant
    Dim i As Long, j As Long
    Dim currentSymbol As String
    '------------------------------------new part----------------------------------------------
    Dim maxHeight As Double
    Dim maxWeight As Double
    Dim heightarray As Variant
    Dim weightarray As Variant
    Dim totalHeight As Double
    Dim totalWeight As Double
    '------------------------------------new part----------------------------------------------

    Set ws = Worksheets("Sheet1")
    With ws
        'clear last time's output
        height = .Cells(.Rows.Count, 1).End(xlUp).row
        If height > 3 Then
            .Range(.Cells(4, 1), .Cells(height, 1)).ClearContents
        End If

        numOfBox = .Cells(1, 1).Value
        width = .Cells(1, .Columns.Count).End(xlToLeft).Column
        If width < 2 Then
            MsgBox "Error: There's no item, please fill your item in Cell B1,C1,..."
            Exit Function
        End If


        '------------------------------------new part----------------------------------------------
        maxHeight = .Cells(2, 1).Value
        maxWeight = .Cells(3, 1).Value
        ReDim heightarray(1 To 1, 1 To width - 1)
        ReDim weightarray(1 To 1, 1 To width - 1)
        heightarray = .Range(.Cells(2, 2), .Cells(2, width)).Value
        weightarray = .Range(.Cells(3, 2), .Cells(3, width)).Value
        '------------------------------------new part----------------------------------------------

        ReDim optionsA(0 To width - 2)
        For i = 0 To width - 2
            optionsA(i) = .Cells(1, i + 2).Value
        Next i

        GenerateCombinations optionsA, results, numOfBox


        ' copy the result to sheet only once
        ReDim outputArray(1 To UBound(results, 1) - LBound(results, 1) + 1, 1 To 1)
        Count = 0
        For i = LBound(results, 1) To UBound(results, 1)
            If Not IsEmpty(results(i)) Then
                'rowNum = rowNum + 1
                str = ""
                totalHeight = 0#
                totalWeight = 0#
                For j = LBound(results(i), 1) To UBound(results(i), 1)
                    currentSymbol = results(i)(j)

                    str = str & currentSymbol 'results(i)(j) is the SYMBOL e.g. A, B, C

                    'look up box's height and weight , increment the totalHeight/totalWeight
                    updateParam currentSymbol, optionsA, heightarray, weightarray, totalHeight, totalWeight

                Next j
                If totalHeight < maxHeight And totalWeight < maxWeight Then
                    Count = Count + 1
                    outputArray(Count, 1) = str
                End If

            '.Cells(rowNum, 1).Value = str
            End If
        Next i
        .Range(.Cells(4, 1), .Cells(UBound(outputArray, 1) + 3, 1)).Value = outputArray
    End With

End Function

Sub updateParam(ByRef targetSymbol As String, ByRef symbolArray As Variant, ByRef heightarray As Variant, ByRef weightarray As Variant, ByRef totalHeight As Double, ByRef totalWeight As Double)
Dim i As Long
Dim index As Long
index = -1
For i = LBound(symbolArray, 1) To UBound(symbolArray, 1)
    If targetSymbol = symbolArray(i) Then
        index = i
        Exit For
    End If
Next i


If index <> -1 Then
    totalHeight = totalHeight + heightarray(1, index + 1)
    totalWeight = totalWeight + weightarray(1, index + 1)
End If
End Sub

Sub GenerateCombinations(ByRef AllFields() As Variant, _
                                             ByRef Result() As Variant, ByVal numOfBox As Long)

  Dim InxResultCrnt As Integer
  Dim InxField As Integer
  Dim InxResult As Integer
  Dim i As Integer
  Dim NumFields As Integer
  Dim Powers() As Integer
  Dim ResultCrnt() As String

  NumFields = UBound(AllFields) - LBound(AllFields) + 1

  ReDim Result(0 To 2 ^ NumFields - 2)  ' one entry per combination
  ReDim Powers(0 To NumFields - 1)          ' one entry per field name

  ' Generate powers used for extracting bits from InxResult
  For InxField = 0 To NumFields - 1
    Powers(InxField) = 2 ^ InxField
  Next

 For InxResult = 0 To 2 ^ NumFields - 2
    ' Size ResultCrnt to the max number of fields per combination
    ' Build this loop's combination in ResultCrnt

    ReDim ResultCrnt(0 To NumFields - 1)
    InxResultCrnt = -1
    For InxField = 0 To NumFields - 1
      If ((InxResult + 1) And Powers(InxField)) <> 0 Then
        ' This field required in this combination
        InxResultCrnt = InxResultCrnt + 1
        ResultCrnt(InxResultCrnt) = AllFields(InxField)
      End If
    Next

    If InxResultCrnt = 0 Then
        Debug.Print "testing"
    End If
    'additional logic here
    If InxResultCrnt >= numOfBox Then
        Result(InxResult) = Empty

    Else
         ' Discard unused trailing entries
        ReDim Preserve ResultCrnt(0 To InxResultCrnt)
        ' Store this loop's combination in return array
        Result(InxResult) = ResultCrnt
    End If

  Next

End Sub

函数stackBox（）
将ws设置为工作表
宽度与长度相同
低矮如长
暗箱一样长
Dim optionsA（）作为变量
Dim results（）作为变量
作为字符串的Dim str
暗输出阵列
Dim ws as Worksheet
Set ws = Worksheets("Sheet2")
....
ws.Range(...)
ws.Cells(...) etc