私の以前の質問はここでした：組み合わせを見つけた後のVBAでのフィルタリング 。では、もう少し詳しく試してみたいと思います。
私は今、このような組み合わせのリストを持っています:
A
B
AB
C
AC
BC
ABC
D
AD
BD
CD
E
AE
BE
CE
新しいマクロでやりたいことは、この情報を取得して、すべての文字を選択するためのオプションがいくつあるかを調べることです。たとえば、オプション 1 の結果は次のようになります。
ABCDE
AC BDE
等.......
1 つのボックスを選択すると、すべてのボックスを取得するために必要な可能性が表示されます。これは私が試した別のコードですが、計算時間が長いためうまく機能しません。
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