Macro to make all possible combinations of data in various columns and rows in excel sheet?

Question

A good solution to this question for one row in excel sheet was offered in another post by user Tony Dallimore.

In the case of a worksheet that contains the following data in one row:

A                      B           C
abc,def,ghi,jkl      1,2,3     a1,e3,h5,j8

After applying the following VBA macro:

Sub Combinations()

  Dim ColCrnt As Long
  Dim ColMax As Long
  Dim IndexCrnt() As Long
  Dim IndexMax() As Long
  Dim RowCrnt As Long
  Dim SubStrings() As String
  Dim TimeStart As Single

  TimeStart = Timer

  With Worksheets("Combinations")

    ' Use row 1 as the source row.  Find last used column.
    ColMax = .Cells(1, Columns.Count).End(xlToLeft).Column

    ' Size Index arrays according to number of columns
    ' Use one based arrays so entry number matches column number
    ReDim IndexCrnt(1 To ColMax)
    ReDim IndexMax(1 To ColMax)

    ' Initialise arrays
    For ColCrnt = 1 To ColMax
      SubStrings = Split(.Cells(1, ColCrnt).Value, ",")
      ' SubStrings is a zero-based array with one entry
      ' per comma separated value.
      IndexMax(ColCrnt) = UBound(SubStrings)
      IndexCrnt(ColCrnt) = 0
    Next
    
    RowCrnt = 3     ' Output generated values starting at row 3

    Do While True

      ' Use IndexCrnt() here.
      ' For this version I output the index values
      For ColCrnt = 1 To ColMax
        SubStrings = Split(.Cells(1, ColCrnt).Value, ",")
        .Cells(RowCrnt, ColCrnt).Value = SubStrings(IndexCrnt(ColCrnt))
      Next
      RowCrnt = RowCrnt + 1

      ' Increment values in IndexCrnt() from right to left
      For ColCrnt = ColMax To 1 Step -1
        If IndexCrnt(ColCrnt) < IndexMax(ColCrnt) Then
          ' This column's current index can be incremented
          IndexCrnt(ColCrnt) = IndexCrnt(ColCrnt) + 1
          Exit For
        End If
        If ColCrnt = 1 Then
          ' Leftmost column has overflowed.
          ' All combinations of index value have been generated.
          Exit Do
        End If
        IndexCrnt(ColCrnt) = 0
        ' Loop to increment next column
      Next

    Loop

  End With

  Debug.Print Format(Timer - TimeStart, "#,###.##")

End Sub

The result is all combinations of data in different columns, while these combinations are displayed in the same worksheet, starting with the third row: (part of the output is displayed below)

abc  1  a1
abc  2  a1
abc  3  a1
abc  1  e3
abc  2  e3
abc  3  h5

However, I would be interested in how this VBA macro can be modified so that it is applied sequentially to more than one row (for any number of rows), while the output would be displayed either two rows below the last row of the input table or on the next worksheet. Unfortunately, my attempts at modification were unsuccessful. thanks in advance for every answer and at the same time this is my first post on stackoverflow, so sorry for any mistakes in the structure of the question.

Example of input table:

A            B           C
abc,def      1,2     a1,e3
abc,def      1,2     a1,e3

Example of output table:

A     B     C
abc   1     a1
abc   1     e3
abc   2     a1
abc   2     e3
def   1     a1
def   1     e3
def   2     a1
def   2     e3
abc   1     a1
abc   1     e3
abc   2     a1
abc   2     e3
def   1     a1
def   1     e3
def   2     a1
def   2     e3

Answer 1

Firstly, I would recommend to break the code into separate Subs and/or Functions. This will make it easier to read, edit, maintain, use, etc.

Secondly, supposing the worksheet looks like shown in the table below, you can split the data in each cell into separate 1D arrays and put those arrays in another 1D array. Thus, you'll get something like a 2D array (like because, there may be different number of elements in each array).

Thirdly, create a temporary 1D array (combs) which will store a single value from each column. Make it's length the same as number of columns in the 2D array.

Lastly, start traversing through the first column of the 2D array (cell A1) and put the values into combs (column number in combs refers to current column number in the 2D array). Then, if it isn't the last column, recursively call this Sub (combinations), else, print the combination (the joint combs).

	A	B	C	D
1	abc,def,ghi,jkl	1,2,3	a1,e3,h5,j8
2

The code:

Private Sub read2D(ByRef arr2D() As Variant)
  Dim r As Integer
  Dim c As Integer
  r = 1
  For c = 1 To 3
    arr2D(c) = Split(Sheet1.Cells(r, c).Value, ",")
  Next c
End Sub

Private Sub combinations( _
    ByRef combs() As Variant, _
    ByRef arr2D() As Variant, _
    Optional ByRef c As Integer = 1)
  Dim r As Integer
  For r = LBound(arr2D(c)) To UBound(arr2D(c))
    combs(c) = arr2D(c)(r)
    If (c + 1) <= UBound(arr2D) Then
      Call combinations(combs, arr2D, c + 1)
    Else
      Debug.Print Join(combs, " ")
    End If
  Next r
End Sub

Private Sub main()
  Dim arr2D(1 To 3) As Variant
  Dim combs(1 To 3) As Variant
  Call read2D(arr2D)
  Call combinations(combs, arr2D)
End Sub

The output:

abc 1 a1        abc 1 e3        abc 1 h5        abc 1 j8
abc 2 a1        abc 2 e3        abc 2 h5        abc 2 j8
abc 3 a1        abc 3 e3        abc 3 h5        abc 3 j8
def 1 a1        def 1 e3        def 1 h5        def 1 j8
def 2 a1        def 2 e3        def 2 h5        def 2 j8
def 3 a1        def 3 e3        def 3 h5        def 3 j8
ghi 1 a1        ghi 1 e3        ghi 1 h5        ghi 1 j8
ghi 2 a1        ghi 2 e3        ghi 2 h5        ghi 2 j8
ghi 3 a1        ghi 3 e3        ghi 3 h5        ghi 3 j8
jkl 1 a1        jkl 1 e3        jkl 1 h5        jkl 1 j8
jkl 2 a1        jkl 2 e3        jkl 2 h5        jkl 2 j8
jkl 3 a1        jkl 3 e3        jkl 3 h5        jkl 3 j8

Answer 2

Here's another approach that should work, it's a bunch of nested for loops to enumerate all the possible combinations. I'd just do a remove duplicates at the end, this should be pretty fast. Alternatively, using a dictionary would work too.

Sub CreateCombos()
    Dim ColumnA As Variant
    Dim ColumnB As Variant
    Dim ColumnC As Variant
    Dim i As Long
    Dim a As Long
    Dim b As Long
    Dim c As Long
    Dim j As Long
    Dim results As Variant
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
    
    'Create an array large enough to hold all the values
    ReDim results(1 To 3, 1 To 50000)
    
    'Iterate each of the combinations listed as comma separated values
    'Should be easy to make this dynamic if you need to iterate specific cells
    For i = 1 To 2
        
        ColumnA = Split(ws.Cells(i, 1), ",")
        ColumnB = Split(ws.Cells(i, 2), ",")
        ColumnC = Split(ws.Cells(i, 3), ",")
        
        For a = LBound(ColumnA) To UBound(ColumnA)
            For b = LBound(ColumnB) To UBound(ColumnB)
                For c = LBound(ColumnC) To UBound(ColumnC)
                    j = j + 1
                    results(1, j) = ColumnA(a)
                    results(2, j) = ColumnB(b)
                    results(3, j) = ColumnC(c)
                Next
            Next
        Next
        
    Next
    
    ReDim Preserve results(1 To 3, 1 To j)
    ws.Range("A4:C" & (j + 3)) = Application.Transpose(results)
    
End Sub

Answer 3

Here's one approach:

Sub Combos()

    Dim rw As Range, col As Collection, c As Range, list
    Dim cDest As Range
    
    Set rw = Range("A1:C1")  'first input row
    Set cDest = Range("H1")  'output start position
    
    'loop while have input data
    Do While Application.CountA(rw) = rw.Cells.Count
        Set col = New Collection
        For Each c In rw.Cells
            col.Add Split(c.Value, ",") 'add arrays to the collection
        Next c
        list = CombineNoDups(col)
        cDest.Resize(UBound(list, 1), UBound(list, 2)).Value = list
        Set cDest = cDest.Offset(UBound(list, 1)) 'move insertion point down
        
        Set rw = rw.Offset(1) 'next input row
    Loop

End Sub

'make all combinations of elements in a collection of 1-d arrays
Function CombineNoDups(col As Collection)

    Dim rv(), tmp()
    Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
    Dim t As Long, i As Long, n As Long, ub As Long, x As Long
    Dim numIn As Long, s As String, r As Long, v, dup As Boolean

    numIn = col.Count
    ReDim pos(1 To numIn)
    ReDim lbs(1 To numIn)
    ReDim ubs(1 To numIn)
    ReDim lengths(1 To numIn)

    t = 0
    For i = 1 To numIn  'calculate # of combinations, and cache bounds/lengths
        lbs(i) = LBound(col(i))
        ubs(i) = UBound(col(i))
        lengths(i) = (ubs(i) - lbs(i)) + 1
        pos(i) = lbs(i)
        t = IIf(t = 0, lengths(i), t * lengths(i))
    Next i

    ReDim rv(1 To t, 1 To numIn) 'resize destination array
    x = 0

    For n = 1 To t

        ReDim tmp(1 To numIn)
        dup = False
        For i = 1 To numIn
            v = col(i)(pos(i))
            If Not IsError(Application.Match(v, tmp, 0)) Then
                dup = True
                Exit For
            Else
                tmp(i) = v
            End If
        Next i

        If Not dup Then
            x = x + 1
            For i = 1 To numIn
                rv(x, i) = tmp(i)
            Next i
        End If

        For i = numIn To 1 Step -1
            If pos(i) <> ubs(i) Then   'Not done all of this array yet...
                pos(i) = pos(i) + 1    'Increment array index
                For r = i + 1 To numIn 'Reset all the indexes
                    pos(r) = lbs(r)    '   of the later arrays
                Next r
                Exit For
            End If
        Next i
    Next n

    CombineNoDups = rv
End Function

Answer 4

Get Row Combinations

• The GetRowCombinations function will return the combinations in a 2D one-based array to easily be dropped on the worksheet as illustrated in the GetRowCombinationsTEST procedure.

Sub GetRowCombinationsTEST()
    Const ProcName As String = "GetRowCombinationsTEST"
    On Error GoTo ClearError

    ' Define constants.
    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "A1"
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A1"
    Const Delimiter As String = ","
    
    ' Reference the workbook ('wb').
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Using the 'RefCurrentRegion' function, reference the source range ('srg').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
    Dim srg As Range: Set srg = RefCurrentRegion(sfCell)
    
    ' Using the 'GetRowCombinations' function, return the combinations
    ' in a 2D one-based array, the destination array ('dData').
    Dim dData As Variant: dData = GetRowCombinations(srg, Delimiter)
    Dim drCount As Long: drCount = UBound(dData, 1)
    Dim dcCount As Long: dcCount = UBound(dData, 2)
    
    ' Reference the destination range ('drg').
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
    Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
    
    ' Write the values from the destination array to the destination range.
    drg.Value = dData
    ' Clear below.
    drg.Resize(dws.Rows.Count - drg.Row - drCount + 1).Offset(drCount).Clear
        
    MsgBox drCount & " combinations generated.", vbInformation

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub


Function GetRowCombinations( _
    ByVal srg As Range, _
    ByVal Delimiter As String) _
As String()
    Const ProcName As String = "GetRowCombinations"
    On Error GoTo ClearError
    
    ' Write the number of rows and columns to variables ('srCount','scCount').
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim scCount As Long: scCount = srg.Columns.Count
    
    ' Some rows may be blank, and some rows may have blank cells.
    
    ' The Source Row Numbers array ('srNumbers') will hold the indexes
    ' of the non-blank rows.
    Dim srNumbers() As Long: ReDim srNumbers(1 To srCount)
    ' The Destination Column Counts array ('dcCounts') will hold
    ' the number of non-blank cells per non-blank row.
    Dim dcCounts() As Long: ReDim dcCounts(1 To srCount)
    
    Dim sr As Long ' Current Source Row
    Dim dcCount As Long ' (Current and Final (Max)) Destination Columns Count
    Dim rCount As Long ' Source Number of Non-Blank Rows
    
    For sr = 1 To srCount
        dcCount = scCount - Application.CountBlank(srg.Rows(sr))
        If dcCount > 0 Then ' the row is not blank
            rCount = rCount + 1
            srNumbers(rCount) = sr
            dcCounts(rCount) = dcCount
        'Else ' the row is blank; do nothing
        End If
    Next sr
    If rCount = 0 Then Exit Function ' all rows are blank
    
    If rCount < srCount Then
        ReDim Preserve srNumbers(1 To rCount)
        ReDim Preserve dcCounts(1 To rCount)
    End If
    
    dcCount = Application.Max(dcCounts)
    
    ' Write the values from the range to the Source array ('sData')
    Dim sData() As Variant: sData = srg.Value
    
    ' The Substrings Data array ('ssData') will hold the zero-based
    ' string arrays created by using the Split function on each string.
    Dim ssData() As Variant: ReDim ssData(1 To rCount, 1 To dcCount)
    ' The Substrings Uppers array ('ssUppers') will hold the upper limits
    ' of the corresponding arrays in the Substrings Data array.
    Dim ssUppers() As Long: ReDim ssUppers(1 To rCount, 1 To dcCount)
    
    Dim r As Long ' Current Row
    Dim sc As Long ' Current Source Column
    Dim dc As Long ' Current Destination Column
    Dim drCount As Long ' (Final, Cumulative) Destination Rows Count
    Dim dprCount As Long ' Destination Rows Count Per Row
    Dim sString As String ' Current Source String
    
    For r = 1 To rCount
        dprCount = 1
        For sc = 1 To scCount
            sString = CStr(sData(srNumbers(r), sc))
            If Len(sString) > 0 Then ' cell is not blank
                dc = dc + 1
                ssData(r, dc) = Split(sString, Delimiter)
                ssUppers(r, dc) = UBound(ssData(r, dc))
                dprCount = dprCount * (ssUppers(r, dc) + 1)
            Else ' cell is blank; do nothing
            End If
        Next sc
        drCount = drCount + dprCount
        dc = 0
    Next r
    Erase sData
    Erase srNumbers
    
    ' The Substrings Indices array ('ssUppers') will hold the current indexes
    ' of the corresponding arrays in the Substrings Data array.
    Dim ssIndices() As Long: ReDim ssIndices(1 To rCount, 1 To dcCount)
    
    ' Define the Destination array ('dData').
    Dim dData() As String: ReDim dData(1 To drCount, 1 To dcCount)
    
    Dim dr As Long ' Current Destination Row (Combination)
    
    For r = 1 To rCount
        dcCount = dcCounts(r)
        Do
            dr = dr + 1
            For dc = 1 To dcCount
                dData(dr, dc) = ssData(r, dc)(ssIndices(r, dc))
            Next dc
            For dc = dcCount To 1 Step -1
                If ssIndices(r, dc) = ssUppers(r, dc) Then
                    If dc = 1 Then
                        Exit Do
                    Else
                        ssIndices(r, dc) = 0
                    End If
                Else
                    ssIndices(r, dc) = ssIndices(r, dc) + 1
                    Exit For
                End If
            Next dc
        Loop
        
    Next r
    
    GetRowCombinations = dData

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a reference to the range starting with the first cell
'               of a range and ending with the last cell of the first cell's
'               Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefCurrentRegion"
    On Error GoTo ClearError

    If FirstCell Is Nothing Then Exit Function
    With FirstCell.Cells(1).CurrentRegion
        Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
            - FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function