title: Memory and execution time reduction for algorithms
body: <p>I have been asked to ask this question again and in a little different context. This is the previous post:</p>
  
  <p><a href="https://stackoverflow.com/questions/12957778/filtering-in-vba-after-finding-combinations">Filtering in VBA after finding combinations</a></p>
  
  <p>I would like to make this code possible with 100 different variables without having excel run out of memory and reducing the execution time significantly.</p>
  
  <p>The problem with the code below is that if I have 100 boxes, excel will run out of memory in the line "Result(0 To 2 ^ NumFields - 2)" ( The code works for &lt; 10 boxes) </p>
  
  <p>This is my input:</p>
  
  <pre><code>3   A   B   C   D   E ...
  7.7 3   1   1   1   2 ...
  5.5 2   1   2   3   3 ...
  </code></pre>
  
  <p>This is the code:</p>
  
  <pre><code>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 &gt; 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 &lt; 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 &amp; 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 &lt; maxHeight And totalWeight &lt; 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 &lt;&gt; -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)) &lt;&gt; 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 &gt;= 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
  </code></pre>