Question

我在excel中有一个非常具体和棘手的情况。基本上我已经被要求进行10次不同的Outlook联系备份迭代并将它们合并在一起。我现在所拥有的东西看起来像这样，但有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

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

对于notes列，一些记录有一些块的注释，而其他记录有相同的块加上更多，其他记录只是添加了注释。基本上，如果单元格的内容相同，只需附加缺少的内容，就需要解决这个问题。

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

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

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

Answer 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

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

在Excel中比较和复制/合并类似行的数据

1 个答案: