Найти отношения между элементами в списке Excel

Question

У меня есть список Excel, который выглядит так:

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

Я пытаюсь найти функцию, чтобы у меня были только ссылки между идентификаторами. Окончательный список будет выглядеть так:

Al Bob
Al Chad
Bob Chad
Bob Dick

Другими словами, из входных данных видно, что люди Ал, Боб и Дик работали над проектом ABC. По моим данным, это означает, что у них есть отношения (то есть они работали над одним проектом). Таким образом, я хотел бы иметь одну строку на отношения.

Answer 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

Этот код выведет комбинации на новый лист с именем "Вывод". Если существует лист с таким именем, будет ошибка. В этом случае вы можете редактировать строку

s.Name = "Output"

изменить имя выходного листа.