Excel VBA: удаление дублирующихся строк и объединение ячеек с уникальными данными

Question

У меня есть файл, который содержит контактную информацию.Там 44 столбца и 680 строк.Каждая строка содержит данные одного человека, и каждый столбец также представляет собой отдельный фрагмент данных.Проблема в том, что для большинства людей есть несколько строк, и каждый раз во многих строках содержится избыточная информация, а также уникальная информация.

Примечание:

1. Естьнет шаблона для количества строк для каждого человека, некоторые могут иметь 3, некоторые только 1
2. Иногда в одной из строк нет уникальных значений
3. Иногда ячейка может быть просто пустой

---

Мой вопрос:

Как объединить строки, чтобы у меня было по одной строке на человека без потери уникальных данных из каждой строки?

Что яесть:

Что мне нужно:

---

PS На изображении «что мне нужно» я поместил объединенные уникальные данные в одну ячейку, но через запятую.Честно говоря, было бы неплохо, если бы я мог автоматически создать новый столбец для уникальных данных (например, если есть новая ячейка #, он добавляет столбец и помещает уникальное значение ячейки в строку, которая теперь будетединственная строка для этого человека.

Если это слишком сложно, это нормально, я могу просто сделать текст в столбец.

Спасибо!

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

тест: