VBA - Finding unique combinations

**xlsnovice** · 03-29-2013, 11:14 AM

I have a table with the following data in Excel:

Christian	Florida	1
Katie	Wisconsin	1
Sean	Alabama	2
Kelly	Georgia	2
Kellyn	South Carolina	3
Matt	Texas	3

What I am trying to do is find all possible combinations based on the numbers without duplicates and set them opposite to each other like this:

Christian	Florida	1	2	Alabama	Sean
Christian	Florida	1	2	Georgia	Kelly
Christian	Florida	1	3	South Carolina	Kellyn
Christian	Florida	1	3	Texas	Matt
Katie	Wisconsin	1	2	Alabama	Sean
Katie	Wisconsin	1	2	Georgia	Kelly
Katie	Wisconsin	1	3	South Carolina	Kellyn
Katie	Wisconsin	1	3	Texas	Matt
Sean	Alabama	2	3	South Carolina	Kellyn
Sean	Alabama	2	3	Texas	Matt
Kelly	Georgia	2	3	South Carolina	Kellyn
Kelly	Georgia	2	3	Texas	Matt

The VBA code I am currently working with is the following but I get too many combinations. I don't need to combine "1" with another "1" for example and I also don't want combinations shown again in the opposite direction. If a combination of "2" and "3" is displayed I don't need the same combination shown again as "3" and "2".

Sub CopyStuff()
    Dim ws As Worksheet, ws1 As Worksheet
    Dim rng As Range, rcell As Range
    Dim LR As Long, lResize As Long
    
    Set ws = Sheets("Sheet1")
    Set ws1 = Sheets("Sheet2")
    
    Set rng = ws.Range("A1:C" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
    
    For Each rcell In Application.Index(rng, 0, 3)
        If IsNumeric(rcell.Value) Then
            LR = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1
            With rng
                .AutoFilter Field:=3, Criteria1:="<>" & rcell.Value
                .Offset(1).Columns(3).SpecialCells(xlCellTypeVisible).Copy
                ws1.Range("D" & LR).PasteSpecial xlPasteValues
                .Offset(1).Columns(2).SpecialCells(xlCellTypeVisible).Copy
                ws1.Range("E" & LR).PasteSpecial xlPasteValues
                .Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Copy
                ws1.Range("F" & LR).PasteSpecial xlPasteValues
                lResize = ws1.Range("D" & ws1.Rows.Count).End(xlUp).Row
                .AutoFilter
                .Range(rcell, rcell.Offset(0, -2)).Copy
                ws1.Range("A" & LR & ":C" & lResize).PasteSpecial xlPasteValues
            End With
        End If
    Next rcell
    
End Sub

**MickG** · 03-29-2013, 02:37 PM

Try this:-
Data sheet1 starting "A1"
Results sheet2 starting "A1.

Sub MG29Mar07
Dim Rng As Range, Dn As Range, n As Long
Dim Dic As Object
Dim Cols As String
Dim c As Long
With Sheets("Sheet1")
Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    Cols = Dn & Dn.Offset(, 1)
    Set Dic.Item(Cols) = Dn
Next
Dim k
For Each k In Dic.keys
    For Each Dn In Rng
        If Not k = Dn & Dn.Offset(, 1) Then
            c = c + 1
            With Sheets("Sheet2")
                .Cells(c, "A") = Dic.Item(k)
                .Cells(c, "B") = Dic.Item(k).Offset(, 1)
                .Cells(c, "C") = Dic.Item(k).Offset(, 2)
                .Cells(c, "D") = Dn.Offset(, 2)
                .Cells(c, "E") = Dn.Offset(, 1)
                .Cells(c, "F") = Dn
            End With
        End If
 Next Dn
Next k


Dim Txt As String
Dim Dic1 As Object
Dim nRng As Range
With Sheets("Sheet2")
Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With
Set Dic1 = CreateObject("scripting.dictionary")
Dic1.CompareMode = vbTextCompare
For Each Dn In Rng
    Txt = Dn & Dn(, 2) & Dn(, 5) & Dn(, 6)
Set Dic1.Item(Txt) = Dn
Next Dn
Dim t
For Each Dn In Rng
    Txt = Dn(, 6) & Dn(, 5) & Dn(, 2) & Dn
    If Dic1.exists(Txt) Then
        If Dn.Row > Dic1.Item(Txt).Row Then
            If nRng Is Nothing Then
                Set nRng = Dn
            Else
                 Set nRng = Union(nRng, Dn)
            End If
        End If
    End If
Next Dn


If Not nRng Is Nothing Then nRng.EntireRow.Delete
End Sub

Regards Mick

**xlsnovice** · 03-29-2013, 03:19 PM

Thanks Mick. This seems to move me a step closer, I now have fewer duplicates. I still have 3 combinations too many:

Christian Florida 1 1 Wisconsin Katie
Sean Florida 2 2 Georgia Kelly
Kellyn South Carolina 3 3 Texas Matt

I am trying to avoid putting identical numbers together. So "1" and "1" or "2" and "2" would not be part of the result.

**MickG** · 03-30-2013, 06:55 AM

Try adding the extension in the line below, shown in red, this gave me the same result as you initial thread.

For Each Dn In Rng
    Txt = Dn(, 6) & Dn(, 5) & Dn(, 2) & Dn
    If Dic1.exists(Txt) Then
        If Dn.Row > Dic1.Item(Txt).Row Or Dn.Offset(, 2) = Dn.Offset(, 3) Then
           If nRng Is Nothing Then
                    Set nRng = Dn
                Else

**jindon** · 03-30-2013, 08:43 AM

It should be simple like this

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long, n As Long
    With Range("a1").CurrentRegion.Resize(, 4)
        a = .Value
        ReDim b(1 To UBound(a, 1) ^ 2, 1 To 6)
        For i = 1 To UBound(a, 1) - 1
            For ii = i + 1 To UBound(a, 1)
                If a(i, 3) <> a(ii, 3) Then
                    n = n + 1
                    For iii = 1 To 3
                        b(n, iii) = a(i, iii)
                        b(n, iii + 3) = a(ii, 4 - iii)
                    Next
                End If
            Next
        Next
        .Offset(, .Columns.Count + 2).Resize(n, 6).Value = b
    End With
End Sub