Question

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

我需要计算所有类型的关系：自我，老板，同侪，直接报告，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

Answer 1

随着阿利斯泰尔对数据透视表的消化，我也有这个

打印到页面

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

在MessageBox中显示

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

计算与分组字符串B相关的字符串A.

1 个答案: