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
CodePudding user response：
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
CodePudding user response：
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
CodePudding user response：
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 faster. 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