I've scoured the entire website trying to look for a macro (or function) that will create unique combinations from a given list in adjacent columns.
So basically, I have:
A 1 F1 R1
B 2 F2
C F3
D
E
And I'm trying to list all the information as (in the same worksheet and in different columns):
A 1 F1 R1
A 1 F2 R1
A 1 F3 R1
A 2 F1 R1
A 2 F2 R1
A 2 F3 R1
B 1 F1 R1
B 1 F2 R1
B 1 F3 R1
B 2 F1 R1
B 2 F2 R1
B 2 F3 R1
...etc.
(added bonus for being able to toggle where the list is printed on the sheet)
The code to get all possible combinations as follows
Option Explicit
Sub Combinations()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim a As Range, b As Range, c As Range, d As Range
Dim x&, y&, z&, w&
For x = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
Set a = ws.Range("A" & x)
For y = 1 To ws.Range("B" & Rows.Count).End(xlUp).Row
Set b = ws.Range("B" & y)
For z = 1 To ws.Range("C" & Rows.Count).End(xlUp).Row
Set c = Range("C" & z)
For w = 1 To ws.Range("D" & Rows.Count).End(xlUp).Row
Set d = ws.Range("D" & w)
Debug.Print a & vbTab & b & vbTab & c & vbTab & d
Set d = Nothing
Next
Set c = Nothing
Next
Set b = Nothing
Next y
Set a = Nothing
Next x
End Sub
and the output
A 1 F1 R1
A 1 F2 R1
A 1 F3 R1
A 2 F1 R1
A 2 F2 R1
A 2 F3 R1
B 1 F1 R1
B 1 F2 R1
B 1 F3 R1
B 2 F1 R1
B 2 F2 R1
B 2 F3 R1
C 1 F1 R1
C 1 F2 R1
C 1 F3 R1
C 2 F1 R1
C 2 F2 R1
C 2 F3 R1
D 1 F1 R1
D 1 F2 R1
D 1 F3 R1
D 2 F1 R1
D 2 F2 R1
D 2 F3 R1
E 1 F1 R1
E 1 F2 R1
E 1 F3 R1
E 2 F1 R1
E 2 F2 R1
E 2 F3 R1
There's a workbook at https://app.box.com/s/47b28f19d794b25511be with both formula- and VBA-based methods to do that.
Try this VBA code:
Type tArray
value As String
count As Long
End Type
Sub combineAll()
Dim sResult(10) As tArray, rRow(10) As Long, str() As String
Dim sRow As Long, sCol As Long
Dim i As Long, r As Long
Dim resRows As Long
sRow = 1: sCol = 1: r = 0
With ActiveSheet
Do
rRow(sCol) = 1
If (Trim(.Cells(sRow, sCol).value) = "") Then Exit Do
Do
If (Trim(.Cells(sRow, sCol).value) = "") Then Exit Do
sResult(sCol).value = sResult(sCol).value & Trim(.Cells(sRow, sCol).value) & ";"
sResult(sCol).count = sResult(sCol).count + 1
sRow = sRow + 1
Loop
sCol = sCol + 1
sRow = 1
Loop
Do
r = r + 1
For i = 1 To sCol - 1
str = Split(sResult(i).value, ";")
.Cells(r, sCol + i).value = str(rRow(i) - 1)
Next i
For i = sCol - 1 To 1 Step -1
If rRow(i) < sResult(i).count Then
rRow(i) = rRow(i) + 1
Exit For
Else
rRow(i) = 1
End If
Next i
If rRow(1) >= sResult(1).count Then Exit Do
Loop
End With
End Sub
