☰

查找 Excel 列表中项目之间的关系

tag-icon • tag-icon microsoft-excel
查找 Excel 列表中项目之间的关系

我有一个如下所示的 Excel 列表：

Project  ID
ABC      Al
ABC      Bob
ABC      Chad
DEF      Bob
DEF      Dick

我正在尝试找到一个函数，以便我只能拥有 ID 之间的链接。最终列表将如下所示：

Al Bob
Al Chad
Bob Chad
Bob Dick

换句话说，您可以从输入中看到 Al、B​​ob 和 Dick 参与了 ABC 项目。在我的数据中，这意味着他们之间存在关系（即他们参与了同一个项目）。因此，我希望每个关系占一行。

答案1

这是一个 VBA 解决方案。您只需选择两列数据（不要选择标题），然后运行Partners。

Sub Partners()
Dim tmpColl As Collection, Projects As Object, v() As Variant, tmp As Variant
Dim s As Worksheet, k As Variant
Set Projects = CreateObject("scripting.dictionary")
Set tmpColl = New Collection
v = Selection.Value
'Use project as a dictionary key. Each key is paired with a collection of the IDs for that project.
For i = LBound(v, 1) To UBound(v, 1)
    If Projects.Exists(v(i, 1)) Then
        Set tmpColl = Projects.Item(v(i, 1))
        tmpColl.Add v(i, 2)
        Projects.Remove v(i, 1)
        Projects.Add v(i, 1), tmpColl
    Else
        Set tmpColl = New Collection
        tmpColl.Add v(i, 2)
        Projects.Add v(i, 1), tmpColl
    End If
Next i
'Create output sheet.
Set s = ThisWorkbook.Worksheets.Add
s.Name = "Output"
s.Range("A1") = "ID1"
s.Range("B1") = "ID2"
For Each k In Projects.Keys
    tmp = ListPairs(Projects.Item(k))
    s.UsedRange.Offset(s.UsedRange.Rows.Count, 0).Resize(UBound(tmp, 1), 2).Value = tmp
Next k
End Sub

Function ListPairs(C As Collection) As Variant
Dim v() As Variant, idx As Long
'Returns each pair combination from collection of items.
idx = 1
If C.Count > 1 Then
    ReDim v(1 To C.Count * (C.Count - 1) / 2, 1 To 2) As Variant
    For i = 1 To C.Count - 1
        For j = i + 1 To C.Count
            v(idx, 1) = C.Item(i)
            v(idx, 2) = C.Item(j)
            idx = idx + 1
        Next j
    Next i
End If
ListPairs = v
End Function

此代码将在名为“Output”的新工作表上输出组合。如果存在此名称的现有工作表，则会出现错误。在这种情况下，您可以编辑行

s.Name = "Output"

更改输出表的名称。

相关内容