0

我在excel中有一个非常具体和棘手的情况。基本上，我的任务是对 Outlook 联系人备份进行 10 次不同的迭代并将它们合并在一起。我现在拥有的东西看起来像这样，但有 90 列和 16,000 行......

Name    LastName    Phone1      Phone2      Email          Notes       
Bob     Jones       123456789               bob@email.com  note1
Bob     Jones       123456789               bob@email.com  note1, note2
Bob     Jones       123456789               bob@email.com  note2
Bob     Jones       123456789   0412345678  bob@email.com  note3

我想要做的是通过匹配电子邮件地址来选择相似的行，然后在电话号码列的情况下，该号码在一行中，而不是其他人将号码复制到所有记录中。

对于注释列，一些记录有一些注释块，而其他记录有相同的块加上更多，其他记录只是添加了注释。基本上它需要确定单元格的内容是否相同，并且只将缺少的内容附加到末尾。

所以最后我希望数据库看起来像这样......

Name    LastName    Phone1      Phone2      Email          Notes       
Bob     Jones       123456789   0412345678  bob@email.com  note1, note2, note3
Bob     Jones       123456789   0412345678  bob@email.com  note1, note2, note3
Bob     Jones       123456789   0412345678  bob@email.com  note1, note2, note3
Bob     Jones       123456789   0412345678  bob@email.com  note1, note2, note3

此时我可以过滤相同的行以删除所有重复项。

4

1 回答 1

1

这应该可以完成工作，但您可能需要调整范围。

Sub Remove_Duplicate()
    Dim LASTROW As Long
    Dim I As Long
    Dim J As Long
    Dim K As Long
    Dim MyVALUE As Variant
    Dim s As String, l As String
    Application.ScreenUpdating = False
    LASTROW = Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LASTROW
        MyVALUE = Cells(I, "E")
        For J = LASTROW To I + 1 Step -1
            If (MyVALUE = Cells(J, "E")) Then
                For K = 1 To 4
                    If (Cells(I, K) = "") Then Cells(I, K) = Cells(J, K)
                Next K

                If (Len(Cells(I, "F").Text) >= Len(Cells(J, "F").Text)) Then
                    s = Cells(J, "F").Text
                    l = Cells(I, "F").Text
                Else
                    s = Cells(I, "F").Text
                    l = Cells(J, "F").Text
                End If
                If Not (s = l) Then
                     If InStr(l, s) = 0 Then
                         Cells(I, "F") = Cells(I, "F") & ", " & s
                     End If
                End If
                Cells(J, "A").EntireRow.Delete
            End If
        Next J
    Next I
    Application.ScreenUpdating = True
End Sub

我假设您的笔记被分隔，", " 并且它当前设置为删除重复的行，但您可能需要调整代码以突出显示它们。

于 2013-01-31T04:59:37.467 回答