VBA finding combinations after picking one and not

Question

My previous question was here: Filtering in VBA after finding combinations . I would now like to try a little more detail.

I now have a list of combinations like this:

A
B
AB
C
AC
BC
ABC
D
AD
BD
CD
E
AE
BE
CE

What I would like a new macro to do is to take this information and find out how many options there are for selecting all letters. So for example Option 1 would result in:

A B C D E

AC B D E

Etc.......

You select one box and you find out the possibilities that are required to have all boxes. This is another code that I have tried, however it does not work very well because long calculation time:

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

This code we have the boxes on sheet 1 with the height and weight, sheet 2 should provide all options, sheet 3 are the limits and sheet 4 are the final options. This one has a long execution time. I would like to reduce this, can anyone help me with this?

If you require more information, give me shout!

---

EDIT

This is the other code, is this prefered over the code above? It was the result from my previous question. I would just like to understand which would be better for me to use. To reduce my execution time and move towards my final result macro explained above, aligning all the options possible.

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

Answer 1

To address your desire to reduce execution time, apply these few simple princples as a start

1. Don't reference the sheet inside loops. There are a number of alternatives, including
   1. copying a range to a variant array then looping over the array
   2. use Find, AutoFilter, or SpecialCells to limit the number of references required.
2. Don't ReDim arrays inside loops, or at least limit the number of times you do.
   
   1. if possible calculate the required size before the loop, or
   2. Dim to a large size, say 100 or 1000, the Redim once that size is used. Redim after the loop to the final actual size.

These two techniques will make the most impact. Others than can also help include:

1. Dim all your variables (use Option Explicit to force yourself to do this)
2. Don't use Variant data type unless there is a specific need to.
3. Use Long rather than Integer

4. Rather than repeatedly referencing the Worksheets collection, decalre a variable, Set it to the required sheet, and use that in the other code. Especially when those sheets are referenced inside a loop.

   Dim ws as Worksheet
   Set ws = Worksheets("Sheet2")
   ....
   ws.Range(...)
   ws.Cells(...) etc
   

5. Use the Range reference format .Range(.Cells(r1, c1), .Cells(r2, c2)) rather than .Range("StringRange")