VBA - Combine All Variations Between Multiple Lists

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.

Input AInput BInput COutput A & BOutput A&B&C
newcarrednew carnew car red
oldshoesnew shoesnew shoes red
bikenew bikenew bike red
old carold car red
old shoesold shoes red
old bikeold bike red

<tbody>
</tbody>


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

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
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
A
B
C
1
Input AInput BInput C
2
newcarred
3
oldshoesblue
4
bikegreen
5
yellow
Sheet: Options

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

Excel 2016 (Windows) 32 bit
A
B
C
D
E
F
1
ABCACBBACBCACABCBA
2
new car rednew car rednew car rednew car rednew car rednew car red
3
new car bluenew shoes rednew car blueold car rednew shoes redold car red
4
new car greennew bike rednew car greennew car bluenew bike rednew shoes red
5
new car yellownew car bluenew car yellowold car blueold car redold shoes red
6
new shoes rednew shoes blueold car rednew car greenold shoes rednew bike red
7
new shoes bluenew bike blueold car blueold car greenold bike redold bike red
8
new shoes greennew car greenold car greennew car yellownew car bluenew car blue
9
new shoes yellownew shoes greenold car yellowold car yellownew shoes blueold car blue
10
new bike rednew bike greennew shoes rednew shoes rednew bike bluenew shoes blue
11
new bike bluenew car yellownew shoes blueold shoes redold car blueold shoes blue
12
new bike greennew shoes yellownew shoes greennew shoes blueold shoes bluenew bike blue
13
new bike yellownew bike yellownew shoes yellowold shoes blueold bike blueold bike blue
14
old car redold car redold shoes rednew shoes greennew car greennew car green
15
old car blueold shoes redold shoes blueold shoes greennew shoes greenold car green
16
old car greenold bike redold shoes greennew shoes yellownew bike greennew shoes green
17
old car yellowold car blueold shoes yellowold shoes yellowold car greenold shoes green
18
old shoes redold shoes bluenew bike rednew bike redold shoes greennew bike green
19
old shoes blueold bike bluenew bike blueold bike redold bike greenold bike green
20
old shoes greenold car greennew bike greennew bike bluenew car yellownew car yellow
21
old shoes yellowold shoes greennew bike yellowold bike bluenew shoes yellowold car yellow
22
old bike redold bike greenold bike rednew bike greennew bike yellownew shoes yellow
23
old bike blueold car yellowold bike blueold bike greenold car yellowold shoes yellow
24
old bike greenold shoes yellowold bike greennew bike yellowold shoes yellownew bike yellow
25
old bike yellowold bike yellowold bike yellowold bike yellowold bike yellowold bike yellow
Sheet: Results


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

Forum statistics

Threads
1,213,497
Messages
6,113,999
Members
448,543
Latest member
MartinLarkin

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