Find Unique Data Combinations in a Series of Rows

Thanks Bernie! Take as much time as you need. I really appreciate your help with this!

I have no programming experience.

I've removed all of the extra carriage returns. I now get a Compile error: User-defined type not defined. This is in the first function (after the first Sub)

Function Unique(values As Variant) As Variant()

    Dim dict As New Scripting.Dictionary

When you copy code from a website that doesn't use code windows, there are often extra carriage returns placed within the text. So put your cursor at the end of any red line (after the _ underscore continuation character) and press delete to remove the next line that is wholly blank.

I'm guessing that you have no programming experience, so I don't think that you will be able to extend it.  Give me some time.....

Thanks Bernie!

I get a compile error: Sub or Function not defined?

Highlighted in yellow:

Sub RemoveNonUniques()

Text in red (under the first End Funciton):

Function ArrayBubbleSort( _

    myArray As Variant, _

    Optional Ascending As Boolean) _

    As Variant

How do I extend the logic to the others?

With your table in starting in A1, the code below will give the pairs. You can extend the logic to do the others.

Option Explicit

Sub RemoveNonUniques()

    Dim rngT As Range

    Dim rngC As Range

    Dim i As Integer

    Dim j As Integer

    Dim k As Integer

    Dim strA As String

    Dim lngR As Long

    Dim vDupes() As Variant

    Dim vUniq() As Variant

    Dim cGood As Collection

    Set rngT = Range("A1").CurrentRegion

    vDupes = rngT.Value

    vUniq = ArrayBubbleSort(Unique(vDupes), True)

    lngR = Cells(Rows.Count, "A").End(xlUp).Row + 5

    For i = LBound(vUniq) To UBound(vUniq) - 1

        Set cGood = New Collection

        For j = i + 1 To UBound(vUniq)

            cGood.Add vUniq(j)

        Next j

        strA = ""

        Set rngC = rngT.Find(vUniq(i), lookat:=xlWhole)

        While rngC.Address <> strA

            If strA = "" Then strA = rngC.Address

            k = cGood.Count

            For j = 1 To k

                If j > k Then Exit For

                If Not IsError(Application.Match(cGood(j), Intersect(rngT, rngC.EntireRow), False)) Then

                    cGood.Remove j

                    k = k - 1

                    j = j - 1

                End If

            Next j

            Set rngC = rngT.FindNext(rngC)

        Wend

        For j = 1 To cGood.Count

            Cells(lngR, 1).Value = vUniq(i)

            Cells(lngR, 2).Value = cGood(j)

            lngR = lngR + 1

        Next j

    Next i

End Sub

Function Unique(values As Variant) As Variant()

    Dim dict As New Scripting.Dictionary

    Dim val As Variant

    For Each val In values

        dict(val) = 1

    Next

    Unique = dict.Keys

End Function

Function ArrayBubbleSort( _

    myArray As Variant, _

    Optional Ascending As Boolean) _

    As Variant

    Dim myTemp As Variant

    Dim myInt() As Variant

    Dim i As Integer

    Dim j As Integer

    ReDim myInt(LBound(myArray) To UBound(myArray))

    For i = LBound(myArray) To UBound(myArray)

        myInt(i) = val(Trim(myArray(i)))

    Next i

    'Do the sort

    For i = LBound(myInt) To UBound(myInt) - 1

        For j = i + 1 To UBound(myInt)

            If Ascending Then

                If myInt(i) > myInt(j) Then

                    myTemp = myInt(j)

                    myInt(j) = myInt(i)

                    myInt(i) = myTemp

                End If

            Else

                If myInt(i) < myInt(j) Then

                    myTemp = myInt(j)

                    myInt(j) = myInt(i)

                    myInt(i) = myTemp

                End If

            End If

        Next j

    Next i

    'Return the array

    ArrayBubbleSort = myInt

End Function