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

Question

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

注意：

1. 每个人有多少行没有模式，有些行可以有 3，只有一些
2. 有时其中一行中没有唯一值
3. 有时一个单元格可能只是空白

---

我的问题：

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

我所拥有的：

我需要什么：

---

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

如果那太难了，那就好了，我可以在栏内输入文字。

谢谢！

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

测试：