Frequency of occurence for every possible combination of values in two columns on the same row

Question

I have a data-set with Product 1 in Column A and Product 2 in Column B.

I would like to build a new table which counts the number of rows on which every possible combination of Product 1 and Product 2 occur. (Preferably regardless of the order in which they occur, but I can clean that up after if needed)

I can build this manually, however I am dealing with hundreds of possible combinations and would like to automate the process with a macro or any other recommendations anyone has.

Example of raw data:

Product 1   Product 2
Cheese          Apple
Crackers    Sausage
Cheese          Sausage
Crackers    Sausage
Apple           Crackers
Apple           Cheese
Cheese          Apple
Cherry          Apple

Example of new summarized table:

Combo               | Count of Combo Occurrences
Cheese and Apple    | 3
Cheese and Sausage  | 1
Cherry and Apple    | 1
Crackers and Sausage| 2
Apple and Crackers  | 1

Thanks in advance

Answer 1

Just in case some poor soul will need this in VBA:

Option Explicit
Sub ComboOccurences()

    ' Remember to check Microsoft Scripting Runtime in References!
    Dim dict As Scripting.Dictionary
    Dim i As Integer, r As Integer, LastRow As Integer
    Dim ColAB As String, ColBA As String

    Set dict = New Scripting.Dictionary
    LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

    For i = 2 To LastRow
        ColAB = Range("A" & i).Value & " and " & Range("B" & i).Value
        ColBA = Range("B" & i).Value & " and " & Range("A" & i).Value
        If Not dict.Exists(ColAB) And Not dict.Exists(ColBA) Then
            dict.Add (ColAB), 1
        ElseIf dict.Exists(ColAB) Then
            dict(ColAB) = dict(ColAB) + 1
        ElseIf dict.Exists(ColBA) Then
            dict(ColBA) = dict(ColBA) + 1
        End If
    Next

    r = 2
    For i = 0 To dict.Count - 1
        Range("D" & r).Value = dict.Keys(i)
        Range("E" & r).Value = dict.Items(i)
        r = r + 1
    Next

End Sub

Result:

Hope this will help somebody!

Answer 2

Late to the party but your question seemed like a fun exercise. For kicks I decided to add an extra layer of complexity by writing it to use any size range & outputting the results to a specified range (or sheet).

Sub Test()
    Call CountUniqueCombinations(Range("A2:D7"), Range("F2"))
End Sub

Private Sub CountUniqueCombinations(ByVal SourceRange As Range, ByVal DestinationRange As Range)
    Dim oRowIndex As Long
    Dim oColIndex As Long
    Dim oRow As New Collection

    For oRowIndex = 0 To SourceRange.Rows.Count - 1
        oValue = ""
        Set oRow = Nothing

        ' Sort Current Row (Output to String)
        For oColIndex = 1 To SourceRange.Columns.Count
            oRow.Add SourceRange(oRowIndex + 1, oColIndex).Value
        Next
        oValue = SortCollection(oRow)

        ' See if Sorted row already Exists if so +1
        Dim oDestRowIndex As Long
        Dim oFound As Boolean
        oFound = False
        For oDestRowIndex = 1 To DestinationRange.Rows.Count
            If DestinationRange(oDestRowIndex, 1).Value = oValue Then
                DestinationRange(oDestRowIndex, 2).Value = CInt(DestinationRange(oDestRowIndex, 2).Value) + 1
                oFound = True
                Exit For
            End If
        Next

        ' if Sorted row doesn't exist add it
        If Not oFound Then
            DestinationRange(DestinationRange.Rows.Count, 1) = oValue
            DestinationRange(DestinationRange.Rows.Count, 1).Offset(0, 1) = 1
            Set DestinationRange = DestinationRange.Resize(DestinationRange.Rows.Count + 1, 1)
        End If

    Next

End Sub

Private Function SortCollection(ByVal oCollection As Collection) As String
    Dim oX As Long, oY As Long
    Dim oTempValue As String

    For oX = 1 To oCollection.Count - 1
        For oY = oX + 1 To oCollection.Count
            If oCollection(oX) > oCollection(oY) Then
                oTempValue = oCollection(oY)
                oCollection.Remove (oY)
                oCollection.Add oTempValue, oTempValue, oX
            End If
        Next
    Next

    For oX = 1 To oCollection.Count
        If oCollection.Item(oX) <> "" Then
            SortCollection = SortCollection & oCollection.Item(oX) & " & "
        End If
    Next

    SortCollection = Left(SortCollection, Len(SortCollection) - 3)
End Function