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

 

[motilulla]

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.

Eric W, I am speechless I owe you always favours this is stun modification of "MyInput and MyOutput variables" which I can change just with one word with cell input only and it worked like magic I am so happy and gratefully to you for this lend a hand.

Please just take a look why it is highlighting and stop the code at below line if I use 5 columns and 6 items per column as per following layout (Note: it works perfect with 5 columns and 5 items per column)

MyOutput.Resize(d3.count).Value = WorksheetFunction.Transpose(d3.keys)

*

A

B

C

D

E

F

G

H

I

J

K

L

M

1

1

1

1

1

1

2

D

K

R

Y

AF

3

E

L

S

Z

AG

4

F

M

T

AA

AH

5

G

N

U

AB

AI

6

H

O

V

AC

AJ

7

I

P

W

AD

AK

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

Good luck and have a good start of the week

Kind Regards,
Moti

 

[Eric W]

Hard to say, it works on my version. I suspect it's because the worksheet TRANSPOSE function has some limitations that have been relaxed in newer versions. You can try this version of the macro which doesn't use TRANSPOSE:

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, OutArray() As Variant, k As Variant

    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:
    
    If d3.Count > Rows.Count - MyInput.Row Then
        MsgBox "Too many rows to fit on this sheet"
        Exit Sub
    End If
    ReDim OutArray(1 To d3.Count, 1 To 1)
    i = 0
    For Each k In d3
        i = i + 1
        OutArray(i, 1) = k
    Next k
    MyOutput.Resize(d3.Count).Value = OutArray
    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

 

[motilulla]

Hard to say, it works on my version. I suspect it's because the worksheet TRANSPOSE function has some limitations that have been relaxed in newer versions.

Eric W, I am sure you are absolutely correct it is my version limitation problem.

You can try this version of the macro which doesn't use TRANSPOSE:

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, OutArray() As Variant, k As Variant

    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:
  
    If d3.Count > Rows.Count - MyInput.Row Then
        MsgBox "Too many rows to fit on this sheet"
        Exit Sub
    End If
    ReDim OutArray(1 To d3.Count, 1 To 1)
    i = 0
    For Each k In d3
        i = i + 1
        OutArray(i, 1) = k
    Next k
    MyOutput.Resize(d3.Count).Value = OutArray
    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

Eric W, this macro I tried with various columns and more then 6 items per column and it worked flawless ? Absolutely solved

I appreciate your help always you have solved all my problems with the older version, which still I am using, and working fine with your support.

I wish you Good Luck ?

Kind Regards,
Moti