VBA - Combine All Variations Between Multiple Lists

B

bt_24

New Member
Joined
Jan 16, 2017
Messages
19
Hi,

Below is an example of what I am trying to accomplish, along with my current code at the bottom. I am trying to create a tool that will loop through multiple lists, generating each unique combination between them. The current code currently works close to expectation but there are 2 issues - A) the column "Output A & B" will show duplicates (understand I could remove them with another line of code but prefer avoiding that if possible) & B) if the column "Input C" is blank the code gets stuck in the loop. I think I might be missing adding in an IF statement somewhere, but am a little stuck.

What I am looking for is some help (suggested code, link to articles, etc) of how to get this current code to work 100% as expected? Extra credit but not necessary I'd love to figure out how to have the code also account for different orders between inputs A, B & C.

[TABLE="width: 418"]
<tbody>[TR]
[TD]Input A[/TD]
[TD]Input B[/TD]
[TD]Input C[/TD]
[TD][/TD]
[TD]Output A & B[/TD]
[TD]Output A&B&C[/TD]
[/TR]
[TR]
[TD]new[/TD]
[TD]car[/TD]
[TD]red[/TD]
[TD][/TD]
[TD]new car[/TD]
[TD]new car red[/TD]
[/TR]
[TR]
[TD]old[/TD]
[TD]shoes[/TD]
[TD][/TD]
[TD][/TD]
[TD]new shoes[/TD]
[TD]new shoes red[/TD]
[/TR]
[TR]
[TD][/TD]
[TD]bike[/TD]
[TD][/TD]
[TD][/TD]
[TD]new bike[/TD]
[TD]new bike red[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]old car[/TD]
[TD]old car red[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]old shoes[/TD]
[TD]old shoes red[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]old bike[/TD]
[TD]old bike red[/TD]
[/TR]
</tbody>[/TABLE]


Code: 
Option Explicit
Sub New_Tool ()

Dim rng1 As Range, rng2 As Range, rng3 As RangeDim rngA As Range, rngB As Range, rngC As Range
Dim rngOut1 As Range, rngOut2 As Range


Set rng1 = Range("B5", Range("B5").End(xlDown))
Set rng2 = Range("c5", Range("c5").End(xlDown))
Set rng3 = Range("d5", Range("d5").End(xlDown))


Set rngOut1 = Range("F5")
Set rngOut2 = Range("G5")


For Each rngA In rng1.Cells
    For Each rngB In rng2.Cells
        For Each rngC In rng3.Cells
        rngOut1 = rngA.Value & " " & rngB.Value
        Set rngOut1 = rngOut1.Offset(1, 0)
               
           rngOut2 = rngA.Value & " " & rngB.Value & " " & rngC.Value
            Set rngOut2 = rngOut2.Offset(1, 0)
        Next
    Next
Next


End Sub
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
Sort by date Sort by votes
Assuming your 3 columns start at "B5:D5", try this for results as per your post, starting "F1 & G1"
Code: 
[COLOR="Navy"]Sub[/COLOR] MG05Jun17
[COLOR="Navy"]Dim[/COLOR] Lst1 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] lst2 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] lst3 [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] a [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nnn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Lst1 = Range("B" & Rows.Count).End(xlUp).Row
lst2 = Range("C" & Rows.Count).End(xlUp).Row
lst3 = Range("D" & Rows.Count).End(xlUp).Row

[COLOR="Navy"]For[/COLOR] n = 5 To Lst1
 [COLOR="Navy"]For[/COLOR] nn = 5 To lst2
    c = c + 1
    Cells(c, "F") = Cells(n, "B") & " " & Cells(nn, "C")
    [COLOR="Navy"]For[/COLOR] nnn = 5 To lst3
        a = a + 1
        Cells(a, "G") = Cells(n, "B") & " " & Cells(nn, "C") & " " & Cells(nnn, "D")
    [COLOR="Navy"]Next[/COLOR] nnn
 [COLOR="Navy"]Next[/COLOR] nn
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Not sure what you mean by "different orders"

With these options ...

Excel 2016 (Windows) 32 bit
[Table="width:, class:head"][tr=bgcolor:#E0E0F0][th] [/th][th]
A​
[/th][th]
B​
[/th][th]
C​
[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
1​
[/td][td]Input A[/td][td]Input B[/td][td]Input C[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
2​
[/td][td]new[/td][td]car[/td][td]red[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
3​
[/td][td]old[/td][td]shoes[/td][td]blue[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
4​
[/td][td][/td][td]bike[/td][td]green[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
5​
[/td][td][/td][td][/td][td]yellow[/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Options[/td][/tr][/table]

The code below returns one of these columns based on user choice in InputBox ...

Excel 2016 (Windows) 32 bit
[Table="width:, class:head"][tr=bgcolor:#E0E0F0][th] [/th][th]
A​
[/th][th]
B​
[/th][th]
C​
[/th][th]
D​
[/th][th]
E​
[/th][th]
F​
[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
1​
[/td][td]ABC[/td][td]ACB[/td][td]BAC[/td][td]BCA[/td][td]CAB[/td][td]CBA[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
2​
[/td][td]new car red[/td][td]new car red[/td][td]new car red[/td][td]new car red[/td][td]new car red[/td][td]new car red[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
3​
[/td][td]new car blue[/td][td]new shoes red[/td][td]new car blue[/td][td]old car red[/td][td]new shoes red[/td][td]old car red[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
4​
[/td][td]new car green[/td][td]new bike red[/td][td]new car green[/td][td]new car blue[/td][td]new bike red[/td][td]new shoes red[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
5​
[/td][td]new car yellow[/td][td]new car blue[/td][td]new car yellow[/td][td]old car blue[/td][td]old car red[/td][td]old shoes red[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
6​
[/td][td]new shoes red[/td][td]new shoes blue[/td][td]old car red[/td][td]new car green[/td][td]old shoes red[/td][td]new bike red[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
7​
[/td][td]new shoes blue[/td][td]new bike blue[/td][td]old car blue[/td][td]old car green[/td][td]old bike red[/td][td]old bike red[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
8​
[/td][td]new shoes green[/td][td]new car green[/td][td]old car green[/td][td]new car yellow[/td][td]new car blue[/td][td]new car blue[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
9​
[/td][td]new shoes yellow[/td][td]new shoes green[/td][td]old car yellow[/td][td]old car yellow[/td][td]new shoes blue[/td][td]old car blue[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
10​
[/td][td]new bike red[/td][td]new bike green[/td][td]new shoes red[/td][td]new shoes red[/td][td]new bike blue[/td][td]new shoes blue[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
11​
[/td][td]new bike blue[/td][td]new car yellow[/td][td]new shoes blue[/td][td]old shoes red[/td][td]old car blue[/td][td]old shoes blue[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
12​
[/td][td]new bike green[/td][td]new shoes yellow[/td][td]new shoes green[/td][td]new shoes blue[/td][td]old shoes blue[/td][td]new bike blue[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
13​
[/td][td]new bike yellow[/td][td]new bike yellow[/td][td]new shoes yellow[/td][td]old shoes blue[/td][td]old bike blue[/td][td]old bike blue[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
14​
[/td][td]old car red[/td][td]old car red[/td][td]old shoes red[/td][td]new shoes green[/td][td]new car green[/td][td]new car green[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
15​
[/td][td]old car blue[/td][td]old shoes red[/td][td]old shoes blue[/td][td]old shoes green[/td][td]new shoes green[/td][td]old car green[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
16​
[/td][td]old car green[/td][td]old bike red[/td][td]old shoes green[/td][td]new shoes yellow[/td][td]new bike green[/td][td]new shoes green[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
17​
[/td][td]old car yellow[/td][td]old car blue[/td][td]old shoes yellow[/td][td]old shoes yellow[/td][td]old car green[/td][td]old shoes green[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
18​
[/td][td]old shoes red[/td][td]old shoes blue[/td][td]new bike red[/td][td]new bike red[/td][td]old shoes green[/td][td]new bike green[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
19​
[/td][td]old shoes blue[/td][td]old bike blue[/td][td]new bike blue[/td][td]old bike red[/td][td]old bike green[/td][td]old bike green[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
20​
[/td][td]old shoes green[/td][td]old car green[/td][td]new bike green[/td][td]new bike blue[/td][td]new car yellow[/td][td]new car yellow[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
21​
[/td][td]old shoes yellow[/td][td]old shoes green[/td][td]new bike yellow[/td][td]old bike blue[/td][td]new shoes yellow[/td][td]old car yellow[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
22​
[/td][td]old bike red[/td][td]old bike green[/td][td]old bike red[/td][td]new bike green[/td][td]new bike yellow[/td][td]new shoes yellow[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
23​
[/td][td]old bike blue[/td][td]old car yellow[/td][td]old bike blue[/td][td]old bike green[/td][td]old car yellow[/td][td]old shoes yellow[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
24​
[/td][td]old bike green[/td][td]old shoes yellow[/td][td]old bike green[/td][td]new bike yellow[/td][td]old shoes yellow[/td][td]new bike yellow[/td][/tr]

[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]
25​
[/td][td]old bike yellow[/td][td]old bike yellow[/td][td]old bike yellow[/td][td]old bike yellow[/td][td]old bike yellow[/td][td]old bike yellow[/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Results[/td][/tr][/table]


Place code in SHEET module of sheet containing options A,B & C
Code: 
Sub GetCombos()
[COLOR=#006400][I]'variables[/I][/COLOR]
    Dim a, b, c
    Dim X, Y, Z
    Dim r As Long, Order As String
[I][COLOR=#006400]'results sheet[/COLOR][/I]
    Dim ws As Worksheet: Set ws = Sheets.Add
    ws.Columns("A").ColumnWidth = 30
[I][COLOR=#006400]'get order[/COLOR][/I]
    Order = GetOrder
    X = Mid(Order, 1, 1): Set X = Range(X & 2, Range(X & Rows.Count).End(xlUp))
    Y = Mid(Order, 2, 1): Set Y = Range(Y & 2, Range(Y & Rows.Count).End(xlUp))
    Z = Mid(Order, 3, 1): Set Z = Range(Z & 2, Range(Z & Rows.Count).End(xlUp))
[I][COLOR=#006400]'write to cells[/COLOR][/I]
    For Each a In X
        For Each b In Y
            For Each c In Z
                r = r + 1
                ws.Cells(r, 1) = GetString(Order, a, b, c)
            Next c
        Next b
    Next a
End Sub

Code: 
Private Function GetString(Order As String, ByVal a As String, ByVal b As String, ByVal c As String) As String
    Const Sp = " "
    Select Case Order
        Case "ABC": GetString = a & Sp & b & Sp & c
        Case "ACB": GetString = a & Sp & c & Sp & b
        Case "BAC": GetString = b & Sp & a & Sp & c
        Case "BCA": GetString = c & Sp & a & Sp & b
        Case "CAB": GetString = b & Sp & c & Sp & a
        Case "CBA": GetString = c & Sp & b & Sp & a
    End Select
End Function

Private Function GetOrder()
    Dim Order As String
    Order = UCase(InputBox("ABC,ACB,BAC,BCA,CAB,CBA", "Which sequence", "ABC"))
    If Len(Order) <> 3 Then Order = "ABC"
    If InStr(Order, "A") = 0 Then Order = "ABC"
    If InStr(Order, "B") = 0 Then Order = "ABC"
    If InStr(Order, "C") = 0 Then Order = "ABC"
    GetOrder = Order
End Function
 
Upvote 0
Hi MikeG,

Thank you very much for the help adjusting this code - your version is working as expected & simple to understand. I was a little surprised to see that we didnt have to use any ranges or IF statements. i definitely need to do more research to get a better understanding of FOR NEXT loops + combing them, to better leverage that in the future.

Best,
bt_24
 
Upvote 0
Hi Yongle,

I really appreciate your reply to this thread on the "extra credit" portion of my request. The output you created with your code is pretty close to what I was looking for, only your version is more advance. Currently my VBA understanding is a little weak, but know that I am reviewing what you made and very grateful for the help. Ideally I want to be able to understand how it works so I'll be able to apply something similar in the future.

Best,
bt_24
 
Upvote 0
You may find it easier to understand if sorting done after values inserted in results sheet
- this adds a simple sort choice for user (could be made more comprehensive if desired)

sheet of Options as in post#3

Place code in SHEET module of sheet containing options A,B & C
Code: 
Sub GetCombos()
[COLOR=#006400][I]'variables[/I][/COLOR]
    Dim a, b, c, r As Long, aVal As String
[I][COLOR=#006400]
'results sheet[/COLOR][/I]
    Dim ws As Worksheet: Set ws = Sheets.Add: ws.Columns("A:D").ColumnWidth = 30
    
[COLOR=#006400][I]'write to cells[/I][/COLOR]
    For Each a In Range("A2", Range("A" & Rows.Count).End(xlUp))
        For Each b In Range("B2", Range("B" & Rows.Count).End(xlUp))
            For Each C In Range("C2", Range("C" & Rows.Count).End(xlUp))
                r = r + 1
                aVal = a & " " & b & " " & c
                ws.Cells(r, 1).Resize(, 4) = Array(aVal, a, b, c)
            Next c
        Next b
    Next a
[I][COLOR=#006400]'sort[/COLOR][/I]
    Call SortIt(ws.Cells(1).CurrentRegion)
End Sub

Code: 
Sub SortIt(rng As Range)
    Dim X
    X = InputBox("Sort on input" & vbCr & "A = 1 , B = 2, C = 3", "Choose", 1)
    Select Case X
        Case 1, 2, 3:          [COLOR=#006400][I] 'leave unchanged, X is the value required for offset[/I][/COLOR]
        Case Else:              X = 1
    End Select
    With rng
        .Parent.Sort.SortFields.Clear
        .Sort .Resize(, 1).Offset(, X), xlAscending
    End With
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question Question
Finding the differences then copy and paste code to a new sheet
Replies
1
Views
667
myall_blues
myall_blues
J
  • Question Question
Multiple conditional formatting
Replies
6
Views
308
StephenCrump
S
2
  • Question Question
VBA Copy Data from Sheet to Email depending on Assignee
Replies
2
Views
527
2000km12
2
K
  • Solved
VBA Code to paste multiple ranges into email and send
Replies
2
Views
4K
Knockout1992
K
D
  • Solved
VBA to provide links to Folders, sub folders and files
Replies
2
Views
2K
davidalldred
D

Forum statistics

Threads
1,224,819
Messages
6,181,153
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top