4 Column Combinations W/ VBA - excel

Question

I have the following code:
Sub combinations()
Range("G2:G" & Range("G2").End(xlDown).Row).ClearContents
Range("H2:G" & Range("H2").End(xlDown).Row).ClearContents
Range("I2:G" & Range("I2").End(xlDown).Row).ClearContents
Range("J2:G" & Range("J2").End(xlDown).Row).ClearContents
Dim c1() As Variant
Dim c2() As Variant
Dim c3() As Variant
Dim c4() As Variant
Dim out() As Variant
Dim j As Long, k As Long, l As Long, m As Long, n As Long
Dim col1 As Range
Dim col2 As Range
Dim col3 As Range
Dim col4 As Range
Dim out1 As Range
Set col1 = Range("A2", Range("A2").End(xlDown))
Set col2 = Range("B2", Range("B2").End(xlDown))
Set col3 = Range("C2", Range("C2").End(xlDown))
Set col4 = Range("D2", Range("D2").End(xlDown))
c1 = col1
c2 = col2
c3 = col3
c4 = col4
Set out1 = Range("G2", Range("K2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4)))
out = out1
j = 1
k = 1
l = 1
m = 1
n = 1
Do While j <= UBound(c1)
Do While k <= UBound(c2)
Do While l <= UBound(c3)
Do While m <= UBound(c4)
out(n, 1) = c1(j, 1)
out(n, 2) = c2(k, 1)
out(n, 3) = c3(l, 1)
out(n, 4) = c4(m, 1)
n = n + 1
m = m + 1
Loop
m = 1
l = l + 1
Loop
l = 1
k = k + 1
Loop
k = 1
j = j + 1
Loop
out1.Value = out
End Sub
It creates all possible combination for values you put in A:A through D:D.
Example of a working table:
Header1 Header2 Header3 Header4
A1 B1 C1 D1
A2 B2 C2 D2
A3 B3 C3 D3
The only time it does not work is when one of the columns only has 1 value.
Example of a not working table:
Header1 Header2 Header3 Header4
A1 B1 C1 D1
B2 C2 D2
B3 C3 D3
I get a
Run-time error '1004;
Is there a way to fix this so that it would work for columns with 1 value as well?

Answer 1

This should work for you. Please note that it will work for any number of columns, not just 4, and that it will also work if any of the columns don't have full population (though each column must have at least one populated cell).
Sub tgr()
Dim ws As Worksheet
Dim rDest As Range
Dim aHeaders() As Variant
Dim aTemp() As Variant
Dim aData() As Variant
Dim aResults() As Variant
Dim vTemp As Variant
Dim ixData As Long
Dim ixResult As Long
Dim ixRow As Long
Dim ixCol As Long
Dim lMaxRows As Long
Dim lResultsBlock As Long
Dim lOverflowResults As Long
Dim bPopulated As Boolean
'Adjust these as necessary
Set ws = ActiveWorkbook.Worksheets(1) 'The worksheet that contains the table of values
Set rDest = ws.Range("G2") 'The worksheet and cell where results should be output to
lResultsBlock = 100000 'The number of rows the results array can contain before having to output results and then continuing
'Get table of values that will be used to create combinations, assume table starts in A1 and has headers
With ws.Range("A1").CurrentRegion
If .Rows.Count = 1 Then Exit Sub 'No data
If .Cells.Count = 2 Then
ReDim aHeaders(1 To 1, 1 To 1)
aHeaders(1, 1) = .Cells(1).Value
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Cells(2).Value
Else
aHeaders = .Resize(1).Value
aData = .Offset(1).Resize(.Rows.Count - 1).Value
End If
lMaxRows = UBound(aData, 1) ^ UBound(aData, 2)
ReDim aResults(1 To lResultsBlock, 1 To UBound(aData, 2))
lOverflowResults = 0
End With
'Clear previous results
ClearResults rDest
'Iterate over the table of values and create every possible combination
For ixRow = 1 To lMaxRows
'Prevent Excel from looking frozen, show a % percent complete
If (ixRow - 1) Mod 10000 = 0 Then
DoEvents
Application.StatusBar = "Processing: " & Format(ixRow / lMaxRows, "0.00%") & " completed..."
End If
'Check if this combination has any empty/blank values
bPopulated = True
ReDim aTemp(1 To UBound(aResults, 2))
For ixCol = 1 To UBound(aResults, 2)
ixData = Int(((ixRow - 1) Mod (UBound(aData, 1) ^ (UBound(aData, 2) - (ixCol - 1)))) / (UBound(aData, 1) ^ (UBound(aData, 2) - ixCol))) + 1
vTemp = aData(ixData, ixCol)
If Len(vTemp) > 0 Then
aTemp(ixCol) = vTemp
Else
'Empty/blank found, skip this combination
bPopulated = False
Exit For
End If
Next ixCol
If bPopulated Then
'No empties/blanks found in this combination, add it to results
ixResult = ixResult + 1
For ixCol = 1 To UBound(aResults, 2)
aResults(ixResult, ixCol) = aTemp(ixCol)
Next ixCol
Erase aTemp
'Output results if the results array is full
If ixResult = UBound(aResults, 1) Then OutputResults ws, rDest, aResults, ixResult, lOverflowResults, aHeaders
End If
Next ixRow
'Output results if results array is at least partially populated
If ixResult > 0 Then OutputResults ws, rDest, aResults, ixResult, lOverflowResults, aHeaders
Application.StatusBar = vbNullString
End Sub
'This will clear any previous results
Sub ClearResults(ByVal arg_rDest As Range)
Dim ws As Worksheet
arg_rDest.CurrentRegion.ClearContents
Application.DisplayAlerts = False
For Each ws In arg_rDest.Worksheet.Parent.Worksheets
If ws.Name Like "Overflow Results (*)" Then ws.Delete
Next ws
Application.DisplayAlerts = True
End Sub
'This will output the current results array to the appropriate destination, accounting for if a new sheet needs to be created and whether headers need to be provided
Sub OutputResults(ByRef arg_wsDest As Worksheet, _
ByVal arg_rDest As Range, _
ByRef arg_aResults As Variant, _
ByRef arg_ixResult As Long, _
ByRef arg_lOverflowResults As Long, _
Optional ByVal arg_aHeaders As Variant)
Dim rDest As Range
Dim lHeaderRow As Long
Dim lRowCount As Long
Dim lColCount As Long
'Check if this is the first time results are being output
If arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Row <= arg_rDest.Row Then
'This is the first time results are being output
arg_lOverflowResults = 0
'Check if headers need to be placed
If IsArray(arg_aHeaders) Then
If arg_rDest.Row = 1 Then lHeaderRow = 1 Else lHeaderRow = arg_rDest.Row - 1
With arg_wsDest.Cells(lHeaderRow, arg_rDest.Column).Resize(, UBound(arg_aHeaders, 2))
.Value = arg_aHeaders
.Font.Bold = True
End With
Set rDest = arg_wsDest.Cells(lHeaderRow + 1, arg_rDest.Column)
Else
Set rDest = arg_rDest
End If
End If
'These are used to create a new, empty results array after results are output
lRowCount = UBound(arg_aResults, 1)
lColCount = UBound(arg_aResults, 2)
'Check if there is room left in the current destination worksheet to contain all of the results
If arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Row + 1 + arg_ixResult > arg_wsDest.Rows.Count Then
'Not enough room found, create a new sheet to continue outputting results on and apply headers if necessary
arg_lOverflowResults = arg_lOverflowResults + 1
Set arg_wsDest = arg_wsDest.Parent.Worksheets.Add(AFter:=arg_wsDest)
arg_wsDest.Name = "Overflow Results (" & arg_lOverflowResults & ")"
If IsArray(arg_aHeaders) Then
With arg_wsDest.Cells(1, arg_rDest.Column).Resize(, UBound(arg_aHeaders, 2))
.Value = arg_aHeaders
.Font.Bold = True
End With
Set rDest = arg_wsDest.Cells(2, arg_rDest.Column)
Else
Set rDest = arg_wsDest.Cells(1, arg_rDest.Column)
End If
Else
'Enough room found, set destination for where results should begin
If rDest Is Nothing Then Set rDest = arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Offset(1)
End If
'Output results
rDest.Resize(arg_ixResult, UBound(arg_aResults, 2)).Value = arg_aResults
'Clear the existing results array and create a new, empty results array
Erase arg_aResults
ReDim arg_aResults(1 To lRowCount, 1 To lColCount)
arg_ixResult = 0
End Sub