Excel 相对于分组字符串B对字符串A进行计数

我有两列A列有分组名称，B列有各种关系

Self
Boss
Peer
Peer
Other
Direct Report
Peer
Self
Peer
Direct Report
Direct Report
Direct Report
Boss

我需要计算所有类型的关系：自我、老板、同事、直接下属、A列中每个名字的其他人

我可以计算与下面Sub的所有关系，但我找不到或不知道如何计算名称组

名字不断变化，所以我不能硬编码

范例

Betty Sue Self(1) Boss(1) Peer(3) Direct Report(1) Other(1)

谢谢

在A列中，我有“分组名称”

Betty Sue
Betty Sue
Betty Sue
Betty Sue
Betty Sue
Betty Sue
Fred Anderson
Fred Anderson
Fred Anderson
Molly Capra
Molly Capra
Molly Capra
Molly Capra
Molly Capra

在B栏我有关系

Self
Boss
Peer
Peer
Other
Direct Report
Peer
Self
Peer
Direct Report
Direct Report
Direct Report
Boss

---

除了阿利斯泰尔关于透视表的建议之外，我还有这个

打印到页面上

Dim Str     As String
Set Rng = range(range("A1"), range("A" & Rows.Count).End(xlUp))
Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
For Each Dn In Rng
        If Not Dic.exists(Dn.Value) Then
            Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
        End If

        If Not Dic(Dn.Value).exists(Dn.Offset(, 3).Value) Then
            Dic(Dn.Value).Add (Dn.Offset(, 3).Value), 1
        Else
            Q = Dic(Dn.Value).Item(Dn.Offset(, 3).Value)
                Q = Q + 1
            Dic(Dn.Value).Item(Dn.Offset(, 3).Value) = Q
        End If
Next Dn
Dim C As Integer
Dim Ac As Integer
C = 4
For Each k In Dic.Keys
   C = C + 1
   Ac = 1
   Cells(Ac, C) = k
        For Each p In Dic(k)
           Ac = Ac + 1
            Cells(Ac, C) = p & " (" & Dic(k).Item(p) & ")"
        Next p
Next k
End Sub  

显示在消息框中

Sub Report()
Dim Dn      As range
Dim Rng     As range
Dim Dic     As Object
Dim Q       As Variant
Dim k       As Variant
Dim p       As Variant
Dim Str     As String
Set Rng = range(range("A2"), range("A" & Rows.Count).End(xlUp))
Set Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
For Each Dn In Rng
        If Not Dic.exists(Dn.Value) Then
            Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
        End If

        If Not Dic(Dn.Value).exists(Dn.Offset(, 1).Value) Then
            Dic(Dn.Value).Add (Dn.Offset(, 1).Value), 1
        Else
            Q = Dic(Dn.Value).Item(Dn.Offset(, 1).Value)
                Q = Q + 1
            Dic(Dn.Value).Item(Dn.Offset(, 1).Value) = Q
        End If
Next Dn

For Each k In Dic.Keys
   Str = Str & k & " :- "
        For Each p In Dic(k)
           Str = Str & p & " (" & Dic(k).Item(p) & ") , "
        Next p
    Str = Str & Chr(10)
Next k
MsgBox Str
End Sub

---

你不能用一个数据透视表吗？好主意阿利斯泰尔，我没有考虑这个问题，谢谢TimoWurn看“过滤独特的价值”。既然你找到了一个解决方案，你就应该把这个问题从答案转到答案，这样问题就出现了。