Excel VBA：删除重复行并合并具有唯一数据的单元格

Question

我有一个包含联系信息的文件。有 44 列和 680 行。每一行包含一个人的数据，每一列也是不同的数据。问题是大多数人都有多行，而且很多时候每行都包含冗余信息以及唯一信息。

注意：

1. 每个人的行数没有规律，有些可以有 3、有的只有1
2. 有时其中一行没有唯一值
3. 有时单元格可能只是空白

---

我的问题：

如何合并这些行，以便我每人拥有一行，而不会丢失每行的唯一数据？

我有什么：

我需要什么：

---

附：在“我需要什么”图像中，我将合并的唯一数据放入同一个单元格中，但用逗号分隔。老实说，如果我可以自动为唯一数据创建一个新列，那就太好了（例如，如果有一个新单元格 # 它会添加一列并将唯一单元格值放在现在将是该人的唯一行。

如果这太难了也没关系，我可以将文本添加到列中。

谢谢！

Answer 1

你可以使用这样的东西：

Sub test()
    Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
    Dic.comparemode = vbTextCompare

    Dim rng As Range: Set rng = Range([A1], Cells(Rows.Count, "A").End(xlUp))
    Dim cl As Range, sPhone$, sCell$, sEmail$, sAddress$

    For Each cl In rng

        sPhone = Cells(cl.Row, "B").Value2
        sCell = Cells(cl.Row, "C").Value2
        sEmail = Cells(cl.Row, "D").Value2
        sAddress = Cells(cl.Row, "E").Value2

        If Not Dic.exists(cl.Value2) Then
            Dic.Add cl.Value2, sPhone & "|" & sCell & "|" & sEmail & "|" & sAddress
        Else
            If Not (Split(Dic(cl.Value2), "|")(0) Like "*" & sPhone & "*") And sPhone <> "" Then
                Dic(cl.Value2) = sPhone & ", " & _
                                 Split(Dic(cl.Value2), "|")(0) & "|" & _
                                 Split(Dic(cl.Value2), "|")(1) & "|" & _
                                 Split(Dic(cl.Value2), "|")(2) & "|" & _
                                 Split(Dic(cl.Value2), "|")(3)
            End If
            If Not Split(Dic(cl.Value2), "|")(1) Like "*" & sCell & "*" And sCell <> "" Then
                Dic(cl.Value2) = Split(Dic(cl.Value2), "|")(0) & "|" & _
                                 sCell & ", " & _
                                 Split(Dic(cl.Value2), "|")(1) & "|" & _
                                 Split(Dic(cl.Value2), "|")(2) & "|" & _
                                 Split(Dic(cl.Value2), "|")(3)

            End If
            If Not Split(Dic(cl.Value2), "|")(2) Like "*" & sEmail & "*" And sEmail <> "" Then
                Dic(cl.Value2) = Split(Dic(cl.Value2), "|")(0) & "|" & _
                                 Split(Dic(cl.Value2), "|")(1) & "|" & _
                                 sEmail & "," & _
                                 Split(Dic(cl.Value2), "|")(2) & "|" & _
                                 Split(Dic(cl.Value2), "|")(3)

            End If
            If Not Split(Dic(cl.Value2), "|")(3) Like "*" & sAddress & "*" And sAddress <> "" Then
                Dic(cl.Value2) = Split(Dic(cl.Value2), "|")(0) & "|" & _
                                 Split(Dic(cl.Value2), "|")(1) & "|" & _
                                 Split(Dic(cl.Value2), "|")(2) & "|" & _
                                 sAddress & "," & _
                                 Split(Dic(cl.Value2), "|")(3)

            End If
        End If
    Next cl

    Dim key, i&, ws As Worksheet
    Set ws = Worksheets.Add: ws.Name = "Result " & Replace(Now, ":", "-")
    With ws
        i = 1
        For Each key In Dic
            .Cells(i, "A").Value2 = key
            .Cells(i, "B").Value2 = Split(Dic(key), "|")(0)
            .Cells(i, "C").Value2 = Split(Dic(key), "|")(1)
            .Cells(i, "D").Value2 = Split(Dic(key), "|")(2)
            .Cells(i, "E").Value2 = Split(Dic(key), "|")(3)
            i = i + 1
        Next key
        ws.Columns("A:E").AutoFit
    End With
End Sub

测试：