同一行的两列中每个可能的值组合的出现频率

Question

我有一个数据集，其中 A 列中的产品 1 和 B 列中的产品 2。

我想建立一个新表来计算产品 1 和产品 2 的每个可能组合出现的行数。 （最好不管它们发生的顺序，但如果需要，我可以在之后清理它）

我可以手动构建它，但是我正在处理数百种可能的组合，并希望使用宏或任何其他人的建议来自动化该过程。

原始数据示例：

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

新汇总表示例：

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

提前致谢

Answer 1

聚会迟到了，但您的问题似乎是一个有趣的练习。对于踢球，我决定通过编写它以使用任何大小范围并将结果输出到指定范围（或工作表）来增加额外的复杂性。

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

Answer 2

以防万一有些可怜的人在 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

结果：

希望这会对某人有所帮助！