Question

After some help on this website I am now looking for more. This was my previous post: stacking and layering boxes in excel

I am now able to make all possible combinations. However my next step would be to set some parameters. By this I mean the height and weight of the boxes. If I were to place on “Sheet2” in Column A by box names (A,B,….) Column B by weight (kg) and Column C by height (millimeters). Then on “Sheet3” I place my maximum height and maximum weight. B2 maximum weight of 30 kg and C3 maximum height of 500 mm.

How can I get my macro to check against these parameters and if they do fit them they are placed in the column as in my previous question and if it goes over my weight or height it does not bother with placing it.

Hope to hear soon 🙂 Starting to enjoy excel!

---

Edit:

Box name    Weight  height
A              1    0.12
B              5    0.92
C              3    0.5
D              2    0.34

……..etc

This is how I would place my input information. I would like this for many boxes, maybe even up to 100

Answer 1

as a enhancement to the previous solution

input format
(Please implement your own input/output farmat after studying my code)

<num of box>   <box name 1>  <box name 2> ... <box name N>
<max height>   <height 1>    <height 2>...  
<max weight>   <weight 1>    <weight 2> ...
<output result 1>
<output result 2>
.
.
.

sample Input & output

3   A   B   C   D   E
7.7 3   1   1   1   2
5.5 2   1   2   3   3
A                   
B                   
AB                  
C                   
AC                  
BC                  
ABC                 
D                   
AD                  
BD                  
CD                  
E                   
AE                  
BE                  
CE

Not limited to integer, you can use floating numbers

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 > 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