ค้นหาความสัมพันธ์ระหว่างรายการในรายการ Excel

ฉันมีรายการ Excel ที่มีลักษณะเช่นนี้:

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

ฉันกำลังพยายามค้นหาฟังก์ชั่นเพื่อให้สามารถเชื่อมโยงระหว่าง ID ได้เท่านั้น รายการสุดท้ายจะมีลักษณะเช่นนี้:

Al Bob
Al Chad
Bob Chad
Bob Dick

กล่าวอีกนัยหนึ่งคุณจะเห็นได้จากข้อมูลที่บุคคล Al, Bob และ Dick ทำงานในโครงการ ABC ในข้อมูลของฉันนั่นหมายความว่าพวกเขามีความสัมพันธ์ (เช่นพวกเขาทำงานในโครงการเดียวกัน) ดังนั้นฉันต้องการมีหนึ่งบรรทัดต่อความสัมพันธ์

นี่คือทางออกของ 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"

เพื่อเปลี่ยนชื่อของแผ่นกระดาษออก