# Excel: Getting a list of every possible combination?



## ajrobson (Aug 2, 2006)

I haven't used Excel in a while and am having a hard time trying to figure out how I can code this. Has anybody done anything similar or know how I can do it?


```
[B]W	X	Y	Z		W2	X2	Y2	Z2[/B] ; These are two lists in my spreadsheet
a	c	j	m		a2	c2	j2	m2
	d	k	n			d2	k2	n2
	e	l	o			e2	l2	o2
	f		p			f2		p2
	g		q			g2		q2
	h					h2		
	i					i2
```
*First* I need to get every combination from W X Y Z e.g. acjm, adkn,aeio etc
*Second *I need to do the same for W2 X2 Y2 Z2 e.g. a2c2j2m2,a2d2k2n2 etc
*Third* I need to get every combination of this new combined list e.g. acjm a2c2j2m2, adkm a2d2k2m2 etc


----------



## Zack Barresse (Jul 25, 2004)

Hi there,

Define "get". Don't understand what you mean. Do you want to count all of the possibilities? Do you want to list them somewhere? Also, are the combinations ONLY 4 per item? Your examples look to be that way, but you haven't specified any other parameters. Please give us a little more to work with.


----------



## ajrobson (Aug 2, 2006)

Thanks for the reply.

By get I mean List e.g. From the first list I would get an output like
acjm
adkn
aeio 
...
...

Then list two would be:
a2c2j2m2
a2d2k2n2
...
..

then finally I would have a list of all possible combinations of those two lists e.g.
acjm a2c2j2m2
adkn a2d2k2n2
aeio a2e2i2o2 
...
...

Yes there are four items W X Y & Z but each can have a different number of items under each of those.


----------



## Zack Barresse (Jul 25, 2004)

So are you saying you want it on a per column basis, in other words you will never have a permutation like this "hkna" from your group 1? How do you want to run this? Do you want it as a sub routine with an inputbox to select the range? Is the range never going to move? Destination to a new worksheet ok? Please, MORE DETAILS.


----------



## ajrobson (Aug 2, 2006)

Yes I would never get hkna I want all combinations where its something from W followed by something X then Y then Z.

An input box to specify the range sounds good as the number of elements under X and X2 is likely to increase - destination can be to a new worksheet would be best as I am not sure how many possible combinations they will be so having it on the same worksheet could get confusing,

Hope this helps more.


----------



## Zack Barresse (Jul 25, 2004)

Quick question about the process you want to take here. Do you want to run these processes simultaneously, or one at a time?


----------



## ajrobson (Aug 2, 2006)

Either would be good as long as the outcome is every possible combination.


----------



## Zack Barresse (Jul 25, 2004)

There are too many options to just run in a single set of code here, so I would recommend a UserForm. I can create them and then upload them, but you would have to download them and install them (I can walk you through it). Does that work? I'll start working on it but may not get it done today.


----------



## ajrobson (Aug 2, 2006)

Thank you!! that would be great


----------



## Zack Barresse (Jul 25, 2004)

Would it be a correct assumption that both of the input ranges should ONLY have 4 columns - ever?


----------



## Rollin_Again (Sep 4, 2003)

I'm getting a headache just thinking about how to code this but I imagine you would need to create several arrays and loop through them to create your different combinations. I'll wait to see if Zack can provide you with a solution before I jump in feet first.

Rollin


----------



## ajrobson (Aug 2, 2006)

Zack Barresse said:


> Would it be a correct assumption that both of the input ranges should ONLY have 4 columns - ever?


Yes that true there is only ever 4 columns.


----------



## Zack Barresse (Jul 25, 2004)

Okay, working on the code. Shouldn't be too long.

@Rollin: I've got the majority of the permutation set, just need to work it into a Userform. I'll post what I have as soon as I can. I'd love your opinion, or if you have another method. I'm using loops and collections.


----------



## Zack Barresse (Jul 25, 2004)

I didn't even ask what version of Excel you're using. With your current data set it wouldn't fit into a 2003 or prior worksheet (with a header row). It fits fine, however, if you're using a 2007 or better worksheet (i.e. xlsm, xlsb). There are ways to overcome this though. What would you like to do there (if anything)? We can overflow it to another column if you'd like. Anyway, let me know, I've got the code otherwise.


----------



## Zack Barresse (Jul 25, 2004)

Okay, well I got impatient and figured you may just want a separate solution. I made two userforms for ease of use, whichever version you are using. Both are pretty much the same but the 2007+ version will error out in previous versions if the data exceeds the rows. You could, if you wanted to, use the 2003 version in 2007 or 2010 and it would work the same. Basically it just overflows to the next column. Of course if you want a cap, as in not to have to scroll 65k+ rows of unique entries, then a cap might make sense, which of course you'll then need to think about the total columns you have.

I'll post the code from each module here, as well as export them in in a zip file which I'll upload.

In a Standard Module named *modMisc*:

```
Option Explicit

Sub ShowPermutUF()
    Load ufPermut
    ufPermut.Show
End Sub

Sub ShowPermutUF_xl2003()
    Load ufPermut_xl2003
    ufPermut_xl2003.Show
End Sub

Public Sub TOGGLEEVENTS(blnState As Boolean)
'Originally written by Zack Barresse
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState Then .CutCopyMode = False
        If blnState Then .StatusBar = False
    End With
End Sub
```
In a Userform called *ufPermut* (controls named as seen in routines):

```
Option Explicit

Private Sub ckbNewWS_Click()
    Select Case Me.ckbNewWS.Value
    Case True
        Me.refDestRng.BackColor = 12632256
        Me.refDestRng.Value = vbNullString
        Me.refDestRng.Enabled = False
    Case False
        Me.refDestRng.BackColor = -2147483643
        Me.refDestRng.Enabled = True
        Me.refDestRng.Value = "A1"
    End Select
End Sub

Private Sub cmbCancel_Click()
    Unload Me
End Sub

Private Sub cmbGo_Click()

    Dim ws1 As Worksheet, ws2 As Worksheet, wsDest As Worksheet
    Dim sWS1 As String, sWS2 As String, sWSDest As String
    Dim r1 As Range, r2 As Range, rDest As Range
    Dim sR1 As String, sR2 As String, sDest As String

    Dim vItem1 As Variant, cItems1 As New Collection
    Dim vItem2 As Variant, cItems2 As New Collection
    Dim vItem3 As Variant, vItem4 As Variant
    Dim cItems3 As New Collection
    Dim iRow As Long, iCol As Long
    Dim iRow2 As Long, iCol2 As Long
    Dim sQuestion As String

    If Me.refFirstRng.Value = "" Or Me.refSecondRng.Value = "" Then
        MsgBox "You have to select two ranges.", vbExclamation, "ERROR!"
        Exit Sub
    End If
    
    On Error Resume Next
    sWS1 = Left(Me.refFirstRng.Value, InStr(1, Me.refFirstRng.Value, "!") - 1)
    sWS2 = Left(Me.refSecondRng.Value, InStr(1, Me.refSecondRng.Value, "!") - 1)
    sR1 = Right(Me.refFirstRng.Value, Len(Me.refFirstRng.Value) - InStrRev(Me.refFirstRng.Value, "!"))
    sR2 = Right(Me.refSecondRng.Value, Len(Me.refSecondRng.Value) - InStrRev(Me.refSecondRng.Value, "!"))
    If Me.ckbNewWS.Value = True Then
        Set wsDest = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.ActiveSheet)
        Set rDest = wsDest.Range("A2")
        rDest.Offset(-1, 0).Value = "Permutations"
    Else
        sQuestion = "The output data needs the selected column and below." & vbNewLine & vbNewLine
        sQuestion = sQuestion & "Do you want to continue?  Any data in cells will be overwritten."
        If MsgBox(sQuestion, vbYesNo, "CONTINUE?") <> vbYes Then GoTo ExitHere
        sWSDest = Left(Me.refDestRng.Value, InStr(1, Me.refDestRng.Value, "!") - 1)
        sDest = Right(Me.refDestRng.Value, Len(Me.refDestRng.Value) - InStrRev(Me.refDestRng.Value, "!"))
        Set wsDest = ThisWorkbook.Sheets(sWSDest)
        Set rDest = wsDest.Range(sDest)
        If rDest.Row = 1 Then
            rDest.Value = "Permutations"
            Set rDest = rDest.Offset(1, 0)
        End If
    End If
    Set r1 = ThisWorkbook.Sheets(sWS1).Range(sR1)
    Set r2 = ThisWorkbook.Sheets(sWS2).Range(sR2)
    Set ws1 = ThisWorkbook.Sheets(sWS1)
    Set ws2 = ThisWorkbook.Sheets(sWS2)
    On Error GoTo 0
    
    Call TOGGLEEVENTS(False)

    If r1 Is Nothing Or r2 Is Nothing Or rDest Is Nothing Then
        MsgBox "An error has occured.", vbExclamation, "ERROR!"
        GoTo ExitHere
    End If
    If r1.Columns.Count <> 4 Or r2.Columns.Count <> 4 Then
        MsgBox "The ranges are not sized propertly.  Must be 4 columns.", vbExclamation, "ERROR!"
        If Me.ckbNewWS.Value = True Then wsDest.Delete
        GoTo ExitHere
    End If

    'First data set permutations into unique collection
    For iCol = r1(1, 1).Column To r1(r1.Rows.Count, r1.Columns.Count).Column
        For iRow = r1(1, 1).Row To r1(r1.Rows.Count, r1.Columns.Count).Row
            If Len(ws1.Cells(iRow, iCol).Value) > 0 Then
                For iCol2 = r1(1, 1).Column To r1(r1.Rows.Count, r1.Columns.Count).Column
                    For iRow2 = r1(1, 1).Row To r1(r1.Rows.Count, r1.Columns.Count).Row
                        If Len(ws1.Cells(iRow2, iCol2).Value) > 0 Then
                            cItems1.Add ws1.Cells(iRow, iCol).Value & ws1.Cells(iRow2, iCol2).Value, _
                                       ws1.Cells(iRow, iCol).Value & ws1.Cells(iRow2, iCol2).Value
                        End If
                    Next iRow2
                Next iCol2
            End If
        Next iRow
    Next iCol
    
    'Second data set permutations into unique collection
    For iCol = r2(1, 1).Column To r2(r2.Rows.Count, r2.Columns.Count).Column
        For iRow = r2(1, 1).Row To r2(r2.Rows.Count, r2.Columns.Count).Row
            If Len(ws1.Cells(iRow, iCol).Value) > 0 Then
                For iCol2 = r2(1, 1).Column To r2(r2.Rows.Count, r2.Columns.Count).Column
                    For iRow2 = r2(1, 1).Row To r2(r2.Rows.Count, r2.Columns.Count).Row
                        If Len(ws1.Cells(iRow2, iCol2).Value) > 0 Then
                            cItems2.Add ws1.Cells(iRow, iCol).Value & ws1.Cells(iRow2, iCol2).Value, _
                                       ws1.Cells(iRow, iCol).Value & ws1.Cells(iRow2, iCol2).Value
                        End If
                    Next iRow2
                Next iCol2
            End If
        Next iRow
    Next iCol
    
    'Unique permutations from first and second permutations together
    For Each vItem3 In cItems1
        For Each vItem4 In cItems2
            cItems3.Add vItem3 & vItem4, vItem3 & vItem4
        Next vItem4
    Next vItem3
    
    'Check total permutations length for data entry
    If cItems3.Count > ws1.Rows.Count - 1 Then
        MsgBox "The first data set is larger than a single column!", vbExclamation, "ERROR!"
    Else
        GoTo EnterData
    End If
    If Me.ckbNewWS.Value = True Then wsDest.Delete
    GoTo ExitHere
    
EnterData:
    iRow = rDest.Row
    For Each vItem1 In cItems3
        wsDest.Cells(iRow, rDest.Column).Value = vItem1
        iRow = iRow + 1
    Next vItem1
    wsDest.Cells.EntireColumn.AutoFit
    Me.Hide
    MsgBox "Permutations complete!", vbOKOnly, "DONE!"
    Unload Me
ExitHere:
    Call TOGGLEEVENTS(True)

End Sub

Private Sub UserForm_Initialize()
    Me.ckbNewWS.Value = True
End Sub
```
In a Userform named *ufPermut_xl2003* (controls named as seen in routines):

```
Option Explicit

Private Sub ckbNewWS_Click()
    Select Case Me.ckbNewWS.Value
    Case True
        Me.refDestRng.BackColor = 12632256
        Me.refDestRng.Value = vbNullString
        Me.refDestRng.Enabled = False
    Case False
        Me.refDestRng.BackColor = -2147483643
        Me.refDestRng.Enabled = True
        Me.refDestRng.Value = "A1"
    End Select
End Sub

Private Sub cmbCancel_Click()
    Unload Me
End Sub

Private Sub cmbGo_Click()

    Dim ws1 As Worksheet, ws2 As Worksheet, wsDest As Worksheet
    Dim sWS1 As String, sWS2 As String, sWSDest As String
    Dim r1 As Range, r2 As Range, rDest As Range
    Dim sR1 As String, sR2 As String, sDest As String

    Dim vItem1 As Variant, cItems1 As New Collection
    Dim vItem2 As Variant, cItems2 As New Collection
    Dim vItem3 As Variant, vItem4 As Variant
    Dim cItems3 As New Collection
    Dim iRow As Long, iCol As Long
    Dim iRow2 As Long, iCol2 As Long
    Dim sQuestion As String

    If Me.refFirstRng.Value = "" Or Me.refSecondRng.Value = "" Then
        MsgBox "You have to select two ranges.", vbExclamation, "ERROR!"
        Exit Sub
    End If
    
    On Error Resume Next
    sWS1 = Left(Me.refFirstRng.Value, InStr(1, Me.refFirstRng.Value, "!") - 1)
    sWS2 = Left(Me.refSecondRng.Value, InStr(1, Me.refSecondRng.Value, "!") - 1)
    sR1 = Right(Me.refFirstRng.Value, Len(Me.refFirstRng.Value) - InStrRev(Me.refFirstRng.Value, "!"))
    sR2 = Right(Me.refSecondRng.Value, Len(Me.refSecondRng.Value) - InStrRev(Me.refSecondRng.Value, "!"))
    If Me.ckbNewWS.Value = True Then
        Set wsDest = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.ActiveSheet)
        Set rDest = wsDest.Range("A2")
        rDest.Offset(-1, 0).Value = "Permutations"
    Else
        sQuestion = "The output data needs the selected column and below." & vbNewLine & vbNewLine
        sQuestion = sQuestion & "Do you want to continue?  Any data in cells will be overwritten."
        If MsgBox(sQuestion, vbYesNo, "CONTINUE?") <> vbYes Then GoTo ExitHere
        sWSDest = Left(Me.refDestRng.Value, InStr(1, Me.refDestRng.Value, "!") - 1)
        sDest = Right(Me.refDestRng.Value, Len(Me.refDestRng.Value) - InStrRev(Me.refDestRng.Value, "!"))
        Set wsDest = ThisWorkbook.Sheets(sWSDest)
        Set rDest = wsDest.Range(sDest)
        If rDest.Row = 1 Then
            rDest.Value = "Permutations"
            Set rDest = rDest.Offset(1, 0)
        End If
    End If
    Set r1 = ThisWorkbook.Sheets(sWS1).Range(sR1)
    Set r2 = ThisWorkbook.Sheets(sWS2).Range(sR2)
    Set ws1 = ThisWorkbook.Sheets(sWS1)
    Set ws2 = ThisWorkbook.Sheets(sWS2)
    On Error GoTo 0
    
    Call TOGGLEEVENTS(False)

    If r1 Is Nothing Or r2 Is Nothing Or rDest Is Nothing Then
        MsgBox "An error has occured.", vbExclamation, "ERROR!"
        GoTo ExitHere
    End If
    If r1.Columns.Count <> 4 Or r2.Columns.Count <> 4 Then
        MsgBox "The ranges are not sized propertly.  Must be 4 columns.", vbExclamation, "ERROR!"
        If Me.ckbNewWS.Value = True Then wsDest.Delete
        GoTo ExitHere
    End If

    'First data set permutations into unique collection
    For iCol = r1(1, 1).Column To r1(r1.Rows.Count, r1.Columns.Count).Column
        For iRow = r1(1, 1).Row To r1(r1.Rows.Count, r1.Columns.Count).Row
            If Len(ws1.Cells(iRow, iCol).Value) > 0 Then
                For iCol2 = r1(1, 1).Column To r1(r1.Rows.Count, r1.Columns.Count).Column
                    For iRow2 = r1(1, 1).Row To r1(r1.Rows.Count, r1.Columns.Count).Row
                        If Len(ws1.Cells(iRow2, iCol2).Value) > 0 Then
                            cItems1.Add ws1.Cells(iRow, iCol).Value & ws1.Cells(iRow2, iCol2).Value, _
                                       ws1.Cells(iRow, iCol).Value & ws1.Cells(iRow2, iCol2).Value
                        End If
                    Next iRow2
                Next iCol2
            End If
        Next iRow
    Next iCol
    
    'Second data set permutations into unique collection
    For iCol = r2(1, 1).Column To r2(r2.Rows.Count, r2.Columns.Count).Column
        For iRow = r2(1, 1).Row To r2(r2.Rows.Count, r2.Columns.Count).Row
            If Len(ws1.Cells(iRow, iCol).Value) > 0 Then
                For iCol2 = r2(1, 1).Column To r2(r2.Rows.Count, r2.Columns.Count).Column
                    For iRow2 = r2(1, 1).Row To r2(r2.Rows.Count, r2.Columns.Count).Row
                        If Len(ws1.Cells(iRow2, iCol2).Value) > 0 Then
                            cItems2.Add ws1.Cells(iRow, iCol).Value & ws1.Cells(iRow2, iCol2).Value, _
                                       ws1.Cells(iRow, iCol).Value & ws1.Cells(iRow2, iCol2).Value
                        End If
                    Next iRow2
                Next iCol2
            End If
        Next iRow
    Next iCol
    
    'Unique permutations from first and second permutations together
    For Each vItem3 In cItems1
        For Each vItem4 In cItems2
            cItems3.Add vItem3 & vItem4, vItem3 & vItem4
        Next vItem4
    Next vItem3
    
'    'Check total permutations length for data entry
'    If cItems3.Count > ws1.Rows.Count - 1 Then
'        MsgBox "The first data set is larger than a single column!", vbExclamation, "ERROR!"
'    Else
'        GoTo EnterData
'    End If
'    If Me.ckbNewWS.Value = True Then wsDest.Delete
'    GoTo ExitHere
    
EnterData:
    iRow = rDest.Row
    iCol = rDest.Column
    For Each vItem1 In cItems3
        wsDest.Cells(iRow, iCol).Value = vItem1
        iRow = iRow + 1
        If iRow > wsDest.Rows.Count Then
            iRow = rDest.Row
            iCol = iCol + 1
            wsDest.Cells(1, iCol).Value = rDest.Offset(-1, 0).Value & iCol
        End If
    Next vItem1
    wsDest.Cells.EntireColumn.AutoFit
    Me.Hide
    MsgBox "Permutations complete!", vbOKOnly, "DONE!"
    Unload Me
ExitHere:
    Call TOGGLEEVENTS(True)

End Sub

Private Sub UserForm_Initialize()
    Me.ckbNewWS.Value = True
End Sub
```
If you just import the userforms you won't have to rename controls and totally remake the userform. But if you just want to copy the code you'll have to adjust the controls names accordingly. Let us know how it goes. It tested fairly well for me, and for 65k+ unique permutations from just your test data alone, I'd say it ran fairly quick as well.


----------



## slurpee55 (Oct 20, 2004)

Uh, holy cow....


----------



## Zack Barresse (Jul 25, 2004)

Oh it's not that bad. LOL!


----------

