VBA macro to create unique permutations from different columns

[dirty_pencil]

[FONT=&quot]Hi,[/FONT]
[FONT=&quot]I am trying to create a macro in VBA that takes data from three different columns and creates unique permutations while excluding any rows that have the same value in the first two columns. Example below;[/FONT]
[FONT=&quot]
[/FONT]
[TABLE="class: yklcuq-19 cUmOil"]
<thead style="margin: 0px; padding: 0px; border: 0px; font: inherit; vertical-align: baseline;">[TR="class: yklcuq-20 dqbluc, bgcolor: rgba(255, 255, 255, 0.8)"]
[TH="class: yklcuq-25 kFFvu, align: center"]1[/TH]
[TH="class: yklcuq-25 kFFvu, align: center"]1[/TH]
[TH="class: yklcuq-25 kFFvu, align: center"]A[/TH]
[/TR]
</thead><tbody style="margin: 0px; padding: 0px; border: 0px; font: inherit; vertical-align: baseline;">[TR="class: yklcuq-20 dqbluc, bgcolor: rgba(255, 255, 255, 0.8)"]
[TD="class: yklcuq-21 gHVYpd"]2[/TD]
[TD="class: yklcuq-21 gHVYpd"]1[/TD]
[TD="class: yklcuq-21 gHVYpd"]B[/TD]
[/TR]
[TR="class: yklcuq-20 dqbluc, bgcolor: rgba(255, 255, 255, 0.8)"]
[TD="class: yklcuq-21 gHVYpd"]3[/TD]
[TD="class: yklcuq-21 gHVYpd"]1[/TD]
[TD="class: yklcuq-21 gHVYpd"]C[/TD]
[/TR]
</tbody>[/TABLE]
[FONT=&quot]Unique permutations, excluding duplicate values in columns one and two would be[/FONT]
[FONT=&quot]2-1-A[/FONT]
[FONT=&quot]2-1-B[/FONT]
[FONT=&quot]2-1-C[/FONT]
[FONT=&quot]3-1-A[/FONT]
[FONT=&quot]3-1-B[/FONT]
[FONT=&quot]3-1-C[/FONT]
[FONT=&quot]
[/FONT]
[FONT=&quot]So permutations like 1-1-A would be exclude, since there is a 1 in both columns.[/FONT]
[FONT=&quot]
[/FONT]
[FONT=&quot]Here is the code that I have now that creates the permutations but doesn't exclude the 1-1-A type instances.

[/FONT]
[FONT=&quot]<code class="yklcuq-7 iRRQrr" style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-stretch: inherit; font-size: 13px; line-height: 20px; font-family: "Noto Mono", Menlo, Consolas, "Courier New", monospace; vertical-align: baseline; background: transparent; color: rgb(34, 34, 34); max-width: 100%; overflow: auto;">Sub

Dim c1() As Variant
Dim c2() As Variant
Dim c3() As Variant
Dim out() As Variant
Dim j, k, l, m As Long


Dim col1 As Range
Dim col2 As Range
Dim col3 As Range
Dim out1 As Range


Set col1 = Range("A2", Range("A2").End(xlDown))
Set col2 = Range("B2", Range("B2").End(xlDown))
Set col3 = Range("C2", Range("C2").End(xlDown))

c1 = col1
c2 = col2
c3 = col3

Set out1 = Range("E2", Range("G2").Offset(UBound(c1) * UBound(c2) * UBound(c3)))
out = out1

j = 1
k = 1
l = 1
m = 1


Do While j <= UBound(c1)
Do While k <= UBound(c2)
Do While l <= UBound(c3)
out(m, 1) = c1(j, 1)
out(m, 2) = c2(k, 1)
out(m, 3) = c3(l, 1)
m = m + 1
l = l + 1
Loop
l = 1
k = k + 1
Loop
k = 1
j = j + 1
Loop


out1.Value = out
End Sub
</code>Any ideas?
[/FONT]

 

[Nine Zero]

try this out

Sub UniqueP()
Dim lrow, counter As Integer
Dim r, q As Range
Dim str As String
lrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
counter = 2
For Each r In Range("A2:A" & lrow)
    If Not r.Value = r.Offset(, 1).Value Then
        str = r.Value & "-" & r.Offset(, 1) & "-"
            For Each q In Range("C2:C" & lrow)
                Range("E" & counter).Value = str & q.Value
                counter = counter + 1
            Next q
    End If
Next r


End Sub

 

[dirty_pencil]

Thanks. Doesn't work out quite as I'd like. If we change the table to the one below I'd like the following permutations.

[TABLE="width: 500"]
<tbody>[TR]
[TD]1[/TD]
[TD]1[/TD]
[TD]A[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]2[/TD]
[TD]B[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]3[/TD]
[TD]C[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]D[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]E[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]F[/TD]
[/TR]
</tbody>[/TABLE]

1-2-A, 1-2-B, 1-2-C, 1-2-D, 1-2-E, 1-2-F
1-3-A, etc.
2-1-A, etc.
2-3-A, etc.

 

[Nine Zero]

ahhh gotcha let me make the quick fix

 

[dirty_pencil]

Could you also make it so the permutations are in different columns starting in D2. So example 1-2-A, 1 would be in D2, 2 would be in E2, and A would be in F2?

 

[Nine Zero]

alright try this one

Sub UniqueP()
Dim lrow, counter As Integer
Dim r, q, s As Range


lrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
counter = 2
For Each r In Range("A2:A" & lrow)
    For Each s In Range("B2:B" & lrow)
        If Not r.Value = s.Value Then
            For Each q In Range("C2:C" & lrow)
                Range("D" & counter).Value = r.Value
                Range("E" & counter).Value = s.Value
                Range("F" & counter).Value = q.Value
                counter = counter + 1
            Next q
        End If
    Next s
Next r


End Sub

 

[dirty_pencil]

it's close. It doesn't include the D,E, and F from the third column.

 

[Nine Zero]

ohh my bad forgot to change that

Sub UniqueP()
Dim arow, brow, crow, counter As Integer
Dim r, q, s As Range
arow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
brow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
crow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
counter = 2
For Each r In Range("A2:A" & arow)
    For Each s In Range("B2:B" & brow)
        If Not r.Value = s.Value Then
            For Each q In Range("C2:C" & crow)
                Range("D" & counter).Value = r.Value
                Range("E" & counter).Value = s.Value
                Range("F" & counter).Value = q.Value
                counter = counter + 1
            Next q
        End If
    Next s
Next r




End Sub

 

[dirty_pencil]

That works well. I tried to scale it for my larger data set and I'm getting a run time '6': Overflow for the counter=counter+1 at 32767. Is there anyway around this?

 

[shg]

Dim arow As Long, brow As Long, crow As Long, counter As Long