Question

我有一个数据集，其中A列为Product 1，B列为Product 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

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

结果：

希望这对某人有帮助！

Answer 2

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

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

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

2 个答案: