0

I've got a really specific and tricky situation in excel. Basically I've been tasked to take 10 different iterations of outlook contact backups and merge them together. What i have at the moment looks something like this but with 90 columns and 16,000 lines...

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

What I want to do is select similar rows by matching the e-mail address and then in the case of the phone number column where the number is in one row and not the others duplicate the number to all records.

For the notes column some records have some chunks of notes and other records have that same chunk plus more added on, other records just have the added on notes. Basically it needs to work out if the content of the cell is the same and only append what is missing to the end.

So at the end I want the database to look like this....

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

At this point I can just filter identical rows to remove all the duplicates.

BenMorel
  • 34,448
  • 50
  • 182
  • 322
Grant
  • 1

1 Answers1

1

This should do the job, but you may have to adjust the ranges.

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

I have assumed that your notes are seperated by ", " Also it is currently set to delete the duplicate row but you may want to adjust the code to highlight them instead.

Rick
  • 1,063
  • 8
  • 26
  • Unfortunately the notes field is VERY poorly organised and doesn't really conform to any sort of standard. I would like a "," between the joined notes but there is not already meaningful ","s in the notes already. – Grant Jan 31 '13 at 05:18
  • Updated code to test the entire string, this will get duplicate notes but there is really no way around this if there is no structure to them. – Rick Jan 31 '13 at 19:07