我之前的问题在这里：Filtering in VBA after find combination 。我现在想尝试更多细节。
我现在有一个这样的组合列表：
A
B
AB
C
AC
BC
ABC
D
AD
BD
CD
E
AE
BE
CE
我想要一个新的宏做的是获取这些信息并找出有多少选项可以选择所有字母。因此，例如选项 1 将导致：
ABCDE
乙二胺四乙酸
ETC.......
您选择一个盒子，您会发现拥有所有盒子所需的可能性。这是我尝试过的另一个代码，但是由于计算时间长，它不能很好地工作：
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
这段代码我们在表 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