Generating a list of combinations (similar to Cartesian Product but more than 1 from each list)

[Excel_can_do_that]

Long time reader first time asker!

I have a set of data and I am looking to generate a list of the combinations, I have found VBA and formulas but can't seem to get it right. It is similar to the Cartesian Product but rather than it being one from each list, there are multiples from each list.

For the example, for the data below I require 2 x West, 4 x North, 1 x South and 5 x East, however if a letter is used in one list it then cannot be used in any of the other lists (e.g. If D is in a combination as West it can't be also in there for North).

Any guidance is appreciated! ?

West	North	South	East
D	D	A	A
E	E	B	B
F	H	C	C
G	I		F
	J		G
	K		H
	L		I
			J
			K
			L

 

[Eric W]

Welcome to MrExcel.

Seems a bit complicated for formulas. A macro should be possible, but it requires some more details. Will there always be 4 columns? What's the maximum number of items in each column (total number of elements as well as number to select)? I assume the letters are place holders for other values. We can work with them as letters, but how do you want the output displayed? A string of letters, or each letter in a different cell on a row?

 

[Excel_can_do_that]

Hi Eric,

Thanks for your questions.

It will either be 4 columns or 2 columns. With maximum elements in each column set as 10 and the total number to select never more that 5.

Correct, the letters are place holders for other values in this example. It would be ideal if each letter appeared in a different cell on a row as a combination. Most of the research and trials the output was generally a delimiter and each combination in one cell.

 

[Excel_can_do_that]

I have also opened a thread on Excel Forum of the same name.

 

[Fluff]

Thanks for letting us know, but in future please provide a link. Thanks

Generating a list of combinations (similar to Cartesian Product but more than 1 from each) [SOLVED]

Long time reader first time asker! I have a set of data and I am looking to generate a list of the combinations, I have found VBA and formulas but can't seem to get it right. It is similar to the Cartesian Product but rather than it being one from each list, there are multiples from each...

www.excelforum.com

 

[Excel_can_do_that]

Hi all, there has been a solution to this thread on Excel Forum:

Generating a list of combinations (similar to Cartesian Product but more than 1 from each) [SOLVED]

Long time reader first time asker! I have a set of data and I am looking to generate a list of the combinations, I have found VBA and formulas but can't seem to get it right. It is similar to the Cartesian Product but rather than it being one from each list, there are multiples from each...

www.excelforum.com

Thank you for your time

 

[Eric W]

I realize you have an answer, but I've been writing this in my head for the last 3 days, and I just needed to scratch that itch. So if you set up your sheet like this:

ME temp.xlsm
	A	B	C	D
1	2	4	1	5
2	D	D	A	A
3	E	E	B	B
4	F	H	C	C
5	G	I		F
6		J		G
7		K		H
8		L		I
9				J
10				K
11				L
Sheet30

where each column is one set, and the top cell in each column is the number you need to take from each set. You can have up to 10 columns, and up to 20 items per column. Of course, if you have too many, it may take a very long time.

Here's the code:

Sub CombosPlus()
Dim nc As Long, ix() As Variant, c As Long, subix(1 To 10) As Byte, ckeys(1 To 20)
Dim ctr As Long, i As Long, j As Long, fl As Boolean, w As Long
Dim d1 As Object, d2 As Object, d3 As Object, str1 As String, str2 As String

    nc = Range("A1").End(xlToRight).Column
    ReDim ix(1 To nc, 1 To 4)
    
    For c = 1 To 10
        subix(c) = c
    Next c
    
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    ctr = 0
    
    For c = 1 To nc
        mydat = Range(Cells(2, c), Cells(2, c).End(xlDown)).Value
        ix(c, 1) = UBound(mydat)
        ix(c, 2) = Cells(1, c)
        If ix(c, 1) < ix(c, 2) Then
            MsgBox ("# of required is more than # available")
            Exit Sub
        End If
        ix(c, 3) = subix
        ix(c, 4) = ckeys
        For r = 1 To UBound(mydat)
            If Not d1.exists(mydat(r, 1)) Then
                ctr = ctr + 1
                d1(mydat(r, 1)) = ctr
                d2(ctr) = mydat(r, 1)
            End If
            ix(c, 4)(r) = d1(mydat(r, 1))
        Next r
    Next c
    
Loop1:
    str1 = ""
    For i = 1 To nc
        For j = 1 To ix(i, 2)
            w = ix(i, 3)(j)
            str1 = str1 & Chr$(ix(i, 4)(w))
        Next j
    Next i
    For i = 1 To Len(str1)
        If InStr(i + 1, str1, Mid(str1, i, 1)) > 0 Then Exit For
    Next i
    If i > Len(str1) Then
        str2 = ""
        For j = 1 To Len(str1)
            str2 = str2 & d2(Asc(Mid(str1, j, 1))) & "|"
        Next j
        d3(str2) = 1
    End If
    
    For i = nc To 1 Step -1
        Call incr(ix, i, fl)
        If fl Then Exit For
    Next i
    If i > 0 Then GoTo Loop1:
    
    Range("L1").Resize(d3.Count).Value = WorksheetFunction.Transpose(d3.keys)
    Range("L1:L" & d3.Count).TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, Other:=True, OtherChar:="|"
        
End Sub

Sub incr(ByRef ix, ByVal i, ByRef fl)
Dim c As Long, a As Long, b As Long

    fl = True
    c = 0
    For a = ix(i, 2) To 1 Step -1
        ix(i, 3)(a) = ix(i, 3)(a) + 1
        If ix(i, 3)(a) <= ix(i, 1) - c Then
            c = ix(i, 3)(a) + 1
            For b = a + 1 To ix(i, 2)
                ix(i, 3)(b) = c
                c = c + 1
            Next b
            Exit For
        End If
        c = c + 1
    Next a
    If a < 1 Then
        fl = False
        For a = 1 To ix(i, 2)
            ix(i, 3)(a) = a
        Next a
    End If
        
End Sub

I did a terrible job on variable names and comments, but as you have a solution, I didn't feel the need to clean it up. But it works, and I got the same answer (165) as on the other forum.

 

[motilulla]

I realize you have an answer, but I've been writing this in my head for the last 3 days, and I just needed to scratch that itch. So if you set up your sheet like this:

ME temp.xlsm
	A	B	C	D
1	2	4	1	5
2	D	D	A	A
3	E	E	B	B
4	F	H	C	C
5	G	I		F
6		J		G
7		K		H
8		L		I
9				J
10				K
11				L
Sheet30

where each column is one set, and the top cell in each column is the number you need to take from each set. You can have up to 10 columns, and up to 20 items per column. Of course, if you have too many, it may take a very long time.

Here's the code:

Sub CombosPlus()
Dim nc As Long, ix() As Variant, c As Long, subix(1 To 10) As Byte, ckeys(1 To 20)
Dim ctr As Long, i As Long, j As Long, fl As Boolean, w As Long
Dim d1 As Object, d2 As Object, d3 As Object, str1 As String, str2 As String

    nc = Range("A1").End(xlToRight).Column
    ReDim ix(1 To nc, 1 To 4)
 
    For c = 1 To 10
        subix(c) = c
    Next c
 
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    ctr = 0
 
    For c = 1 To nc
        mydat = Range(Cells(2, c), Cells(2, c).End(xlDown)).Value
        ix(c, 1) = UBound(mydat)
        ix(c, 2) = Cells(1, c)
        If ix(c, 1) < ix(c, 2) Then
            MsgBox ("# of required is more than # available")
            Exit Sub
        End If
        ix(c, 3) = subix
        ix(c, 4) = ckeys
        For r = 1 To UBound(mydat)
            If Not d1.exists(mydat(r, 1)) Then
                ctr = ctr + 1
                d1(mydat(r, 1)) = ctr
                d2(ctr) = mydat(r, 1)
            End If
            ix(c, 4)(r) = d1(mydat(r, 1))
        Next r
    Next c
 
Loop1:
    str1 = ""
    For i = 1 To nc
        For j = 1 To ix(i, 2)
            w = ix(i, 3)(j)
            str1 = str1 & Chr$(ix(i, 4)(w))
        Next j
    Next i
    For i = 1 To Len(str1)
        If InStr(i + 1, str1, Mid(str1, i, 1)) > 0 Then Exit For
    Next i
    If i > Len(str1) Then
        str2 = ""
        For j = 1 To Len(str1)
            str2 = str2 & d2(Asc(Mid(str1, j, 1))) & "|"
        Next j
        d3(str2) = 1
    End If
 
    For i = nc To 1 Step -1
        Call incr(ix, i, fl)
        If fl Then Exit For
    Next i
    If i > 0 Then GoTo Loop1:
 
    Range("L1").Resize(d3.Count).Value = WorksheetFunction.Transpose(d3.keys)
    Range("L1:L" & d3.Count).TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, Other:=True, OtherChar:="|"
     
End Sub

Sub incr(ByRef ix, ByVal i, ByRef fl)
Dim c As Long, a As Long, b As Long

    fl = True
    c = 0
    For a = ix(i, 2) To 1 Step -1
        ix(i, 3)(a) = ix(i, 3)(a) + 1
        If ix(i, 3)(a) <= ix(i, 1) - c Then
            c = ix(i, 3)(a) + 1
            For b = a + 1 To ix(i, 2)
                ix(i, 3)(b) = c
                c = c + 1
            Next b
            Exit For
        End If
        c = c + 1
    Next a
    If a < 1 Then
        fl = False
        For a = 1 To ix(i, 2)
            ix(i, 3)(a) = a
        Next a
    End If
     
End Sub

I did a terrible job on variable names and comments, but as you have a solution, I didn't feel the need to clean it up. But it works, and I got the same answer (165) as on the other forum.

Hello Eric W, since long time I needed a macro, which can limit the numbers to take from the each set of group. With a deep search I have come across your thread and find it very useful for my necessity I tried a macro and it is doing a nice performance it is really masterpiece coding.

I need a favour from you no hurry when you can please could you change the data address instead of A1:D11... can you change them to pick from G1:J11 and the out put result instead of
L1 to be changed in the cell G16 to right and downside.

I tried myself to change the address but did not get it work, as it should need your hand to help me

Thank you.

I am using Excel 2000

Regards,
Moti

 

[motilulla]

Hello Eric W, since long time I needed a macro, which can limit the numbers to take from the each set of group. With a deep search I have come across your thread and find it very useful for my necessity I tried a macro and it is doing a nice performance it is really masterpiece coding.

I need a favour from you no hurry when you can please could you change the data address instead of A1:D11... can you change them to pick from G1:J11 and the out put result instead of
L1 to be changed in the cell G16 to right and downside.

I tried myself to change the address but did not get it work, as it should need your hand to help me

Thank you.

I am using Excel 2000

Regards,
Moti

@Eric W, please help when you can

Thank you

Regards,
Moti

 

[Eric W]

Try this:

Sub CombosPlus()
Dim nc As Long, ix() As Variant, c As Long, subix(1 To 10) As Byte, ckeys(1 To 20)
Dim ctr As Long, i As Long, j As Long, fl As Boolean, w As Long
Dim d1 As Object, d2 As Object, d3 As Object, str1 As String, str2 As String
Dim MyInput As Range, MyOutput As Range

    Set MyInput = Range("G1")
    Set MyOutput = Range("G16")
    
    nc = MyInput.End(xlToRight).Column - MyInput.Column + 1
    ReDim ix(1 To nc, 1 To 4)
    
    For c = 1 To 10
        subix(c) = c
    Next c
    
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    ctr = 0
    
    For c = 1 To nc
        mydat = Range(MyInput.Offset(1, c - 1), MyInput.Offset(1, c - 1).End(xlDown)).Value
        ix(c, 1) = UBound(mydat)
        ix(c, 2) = MyInput.Offset(, c - 1)
        If ix(c, 1) < ix(c, 2) Then
            MsgBox ("# of required is more than # available")
            Exit Sub
        End If
        ix(c, 3) = subix
        ix(c, 4) = ckeys
        For r = 1 To UBound(mydat)
            If Not d1.exists(mydat(r, 1)) Then
                ctr = ctr + 1
                d1(mydat(r, 1)) = ctr
                d2(ctr) = mydat(r, 1)
            End If
            ix(c, 4)(r) = d1(mydat(r, 1))
        Next r
    Next c
    
Loop1:
    str1 = ""
    For i = 1 To nc
        For j = 1 To ix(i, 2)
            w = ix(i, 3)(j)
            str1 = str1 & Chr$(ix(i, 4)(w))
        Next j
    Next i
    For i = 1 To Len(str1)
        If InStr(i + 1, str1, Mid(str1, i, 1)) > 0 Then Exit For
    Next i
    If i > Len(str1) Then
        str2 = ""
        For j = 1 To Len(str1)
            str2 = str2 & d2(Asc(Mid(str1, j, 1))) & "|"
        Next j
        d3(str2) = 1
    End If
    
    For i = nc To 1 Step -1
        Call incr(ix, i, fl)
        If fl Then Exit For
    Next i
    If i > 0 Then GoTo Loop1:
    
    MyOutput.Resize(d3.Count).Value = WorksheetFunction.Transpose(d3.keys)
    MyOutput.Resize(d3.Count).TextToColumns Destination:=MyOutput, DataType:=xlDelimited, Other:=True, OtherChar:="|"
        
End Sub

Sub incr(ByRef ix, ByVal i, ByRef fl)
Dim c As Long, a As Long, b As Long

    fl = True
    c = 0
    For a = ix(i, 2) To 1 Step -1
        ix(i, 3)(a) = ix(i, 3)(a) + 1
        If ix(i, 3)(a) <= ix(i, 1) - c Then
            c = ix(i, 3)(a) + 1
            For b = a + 1 To ix(i, 2)
                ix(i, 3)(b) = c
                c = c + 1
            Next b
            Exit For
        End If
        c = c + 1
    Next a
    If a < 1 Then
        fl = False
        For a = 1 To ix(i, 2)
            ix(i, 3)(a) = a
        Next a
    End If
        
End Sub

Just set the MyInput and MyOutput variables at the top to be the top left corner of the input and output ranges.