如何创建唯一列表？

Question

我一直在尝试获取电子邮件列表，然后找到所有可能附加到这些电子邮件的相关电子邮件。例如，我可能有一个如下所示的列表：

SME	Backup	Comp	A1	A2
Person A	Person B	Person C	Person D	Person E
Person A	Person B	Person F	Person G
Person A	Person B	Person F	Person H

我想把它变成这样：

SME	CONTACTS
Person A	Person B; Person C; Person D; Person E; Person F; Person G; Person H

基本上，获取与该特定 SME 相关的个人的唯一列表。当然，我的实际数据中有多个SME，所以我需要循环这个。

Answer 1

如果您确实需要 VBA 来执行此操作，请查看 https://www.youtube.com/watch?v=6LOsQFipqkw

您也可以使用 Power Query 来完成：

将 table 加载到 Power Query
Select 除了第一列之外的所有列
逆透视列
删除不必要的列
删除重复行
关闭并加载

Answer 2

使用Dictionary Objects

Option Explicit

Sub macro1()

    Dim wb As Workbook
    Dim wsIn As Worksheet, wsOut As Worksheet, cell As Range
    Dim dict As Object, key, SME As String, r As Long, c As Long
    Dim ar As Variant

    Set wb = ThisWorkbook
    Set wsIn = wb.Sheets("Sheet1")
    Set wsOut = wb.Sheets("Sheet2")

    Set dict = CreateObject("Scripting.Dictionary")

    ' put data into array
    ar = wsIn.UsedRange.Value2

    ' input
    For r = 2 To UBound(ar) '2 - avoid hedaer
        SME = Trim(ar(r, 1))
        For c = 1 To UBound(ar, 2)
            If Len(ar(r, c)) > 0 Then
                If c = 1 Then
                    If Not dict.exists(SME) Then
                        Set dict(SME) = CreateObject("Scripting.Dictionary")
                    End If
                Else
                    dict(SME)(ar(r, c)) = 1
                End If
            End If
        Next
    Next

    ' output
    With wsOut
        .Cells.Clear
        .Range("A1:B1") = Array("SME", "CONTACTS")
        .Range("A1:B1").Font.Bold = True
        Set cell = .Range("A2")
    End With
    For Each key In dict.keys
        cell = key
        cell.Offset(0, 1) = Join(dict(key).keys, "; ")
        Set cell = cell.Offset(1, 0)
    Next
    wsOut.Activate
    wsOut.Range("A1").Select
    MsgBox dict.Count & " SMEs written to " & wsOut.Name, vbInformation

End Sub

如何创建唯一列表？

How to Create Unique Lists?

excel

vba

pivot-table

excel-formula

excel-2016