Create programmatically list of combinations for choices from data sets in excel vba

[somethinglikeant]

Hi all,

I am wondering if anyone knows of a neat way to do this:-
Say I have 3 data sets
Data set 1 is {Red,Blue,Green}
Data set 2 is {Car, Lorry}
Data set 3 is {Small,Large}

Is there a way of programmatically creating a list of combinations of
selections from these groups.
I know there are 3*2*2 = 12 combinations
I would like to create a list such as

Red Car Small
Red Car Large
Red Lorry Small
Red Lorry Large
Blue Car Small
Blue Car Large
Blue Lorry Small
Blue Lorry Large
Green Car Small
Green Car Large
Green Lorry Small
Green Lorry Large

I would like this list to always total the number of combinations
dependant on the number of data sets and elements in this set. I want a
pure procedure to handle x data sets each with however many elements.

I have each data set under headings in a spreadsheet.

I have got so far with the code and become unstuck.

Any help appreciated,

somethinglikeant

 

[Tom Ogilvy]

Assume each group will at least two members
Sub gencombinations()
Dim rng1 as Range, rng2 as Range, rng3 as Range
Dim cell1 as Range, cell2 as Range, cell3 as Range
set rng1 = Range(cells(2,1),cells(2,1).End(xldown))
set rng2 = Range(cells(2,2),cells(2,2).End(xldown))
set rng3 = Range(cells(2,3),cells(2,3).End(xldown))
for each cell1 in rng1
for each cell2 in rng2
for each cell3 in rng3
cells(rw,4) = cell1
cells(rw,5) = cell2
cells(rw,6) = cell3
Next cell3
Next cell2
Next cell1
End Sub

 

[somethinglikeant]

Many Thanks for this Tom,

Here is the completed code for the application I have created with your
help:-

Sub CombinationsGenerator()

'declare variables
Dim numfields As Integer, numitems() As Integer
Dim cl1, cl2, cl3, cl4, cl5, cl6, cl7, cl8, cl9, cl10 As Range
Dim a As Integer: a = 2 'initialise
Dim q As Integer: q = 1 'initialise

'update status bar and switch off screenupdating and calculation
Application.StatusBar = "Creating Combinations"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'count number of fields
numfields = Application.WorksheetFunction.CountA(Range("A1:J1"))

'count number of items in each field
ReDim numitems(1 To numfields)
For i = 1 To numfields
numitems(i) = Application.WorksheetFunction.CountA(Columns(i)) - 1
Next i

'define data ranges
ReDim datarange(1 To numfields)
For i = 1 To numfields
If numitems(i) > 0 Then
Range(Cells(2, i), Cells(2 + numitems(i) - 1, i)).Select
Else
Range(Cells(2, i), Cells(2, i)).Select
End If
datarange(i) = Selection.Address
Next i

'prepare to write to output sheet
Sheets("Output").Columns("A:M").ClearContents
Sheets("Output").Select: [A2].Select

'copy header labels to other sheets
Sheets("Input").Rows("1:1").Copy Sheets("Output").Rows("1:1")
Sheets("Input").Rows("1:1").Copy Sheets("Invalid").Rows("1:1")

'write combinations
On Error Resume Next
For Each cl1 In Sheets("Input").Range(datarange(1))
For Each cl2 In Sheets("Input").Range(datarange(2))
For Each cl3 In Sheets("Input").Range(datarange(3))
For Each cl4 In Sheets("Input").Range(datarange(4))
For Each cl5 In Sheets("Input").Range(datarange(5))
For Each cl6 In Sheets("Input").Range(datarange(6))
For Each cl7 In Sheets("Input").Range(datarange(7))
For Each cl8 In Sheets("Input").Range(datarange(8))
For Each cl9 In Sheets("Input").Range(datarange(9))
For Each cl10 In Sheets("Input").Range(datarange(10))
Cells(a, 1) = cl1
Cells(a, 2) = cl2
Cells(a, 3) = cl3
Cells(a, 4) = cl4
Cells(a, 5) = cl5
Cells(a, 6) = cl6
Cells(a, 7) = cl7
Cells(a, 8) = cl8
Cells(a, 9) = cl9
Cells(a, 10) = cl10
Application.StatusBar = "Creating Combinations :- " & a - 1
a = a + 1
Next cl10
Next cl9
Next cl8
Next cl7
Next cl6
Next cl5
Next cl4
Next cl3
Next cl2
Next cl1
Columns("A:J").AutoFit

'calculate the number of records created and inform via pop-up
For i = 1 To numfields
If numitems(i) > 0 Then totalrecords = q * numitems(i)
q = totalrecords
Next i
MsgBox totalrecords & " combinations were generated", vbInformation,
"Combinations Generator"

'add script and index formulas to output tab
Application.StatusBar = "Inserting Script and Index functions."
Sheets("Input").Range("K2:L2").Copy
Sheets("Output").Select: [K2].Select
Do Until IsEmpty(ActiveCell.Offset(0, -10))
ActiveCell.Offset(1, 0).Select
Loop
Range("K2:L" & ActiveCell.Row - 1).PasteSpecial xlPasteFormulas
[A2].Select

'reset calculation and screenupdating
Application.CutCopyMode = False: Application.StatusBar = "Calculating"
MsgBox "Procedure completed", vbInformation, "Combinations Generator"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic: Calculate
Application.StatusBar = ""

End Sub

If you would like me to send you the workbook to review or have any
further commnets please let me know.

Many Thanks again