Question

I am layering, stacking my options in excel. I have asked the question in a similar way, however I now want to put some more detail into it. If I have n number of boxes to stack, the possible options to stack them is 2^n-1. Let me give an example of 3 boxes and we give them the names A, B, C and D. The way they are stacked does not matter, meaning AB=BA and ABC=CAB, they count as 1 stack option. The result would be:

A, B, C, AB, BC, AC, ABC

Now I would like to create an excel file which in which I will enter the boxes letters and it gives me a list of all the possibilities for stacking. So I would provide the number of boxes and the letters. (3 boxes, A, B, C) Excel reads this in and gives me in cells the options.

Is it possible to get the options in a row underneath each other? for n number of boxes?

Is this possible? Can anyone help me with this?

Thank you in advanced!

Answer 1

Some Code modified from Tony Dallimore’s post on Creating a list of all possible unique combinations from an array (using VBA)

usage:

1. in Macro “stackBox” — change “Sheet1” to the worksheet name you
   want

2. input the Number of boxes in cell A1

3. input the name in B1, C1, … and so on ..

4. call stackBox

Input Format & Output result in “Sheet1”:

3   A   B   C   D   E
A                   
B                   
AB                  
C                   
AC                  
BC                  
ABC                 
D                   
AD                  
BD                  
ABD                 
CD                  
ACD                 
BCD                 
E                   
AE                  
BE                  
ABE                 
CE                  
ACE                 
BCE                 
DE                  
ADE                 
BDE                 
CDE 

The 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
    Set ws = Worksheets("Sheet1")
    With ws
        'clear last time's output
        height = .Cells(.Rows.Count, 1).End(xlUp).row
        If height > 1 Then
            .Range(.Cells(2, 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
        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 = ""

                For j = LBound(results(i), 1) To UBound(results(i), 1)
                    str = str & results(i)(j)
                Next j
                Count = Count + 1
                outputArray(Count, 1) = str
            '.Cells(rowNum, 1).Value = str
            End If
        Next i
        .Range(.Cells(2, 1), .Cells(UBound(outputArray, 1) + 1, 1)).Value = outputArray
    End With

End Function

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