Excel lead merge

[mrjjman]

Hey Everyone, I have lead lists I'm working on, but sometimes there are duplicates, where 1 will have the email address and the other will have the date of birth. I don't want to get rid of both, but I want to merge them. For example:

First Name Last Name Email Birthday Phone
John Smith 1@1.com 404-555-1212
John Smith 01/01/1960 404-555-1212

I would like it to be like this:
First Name Last Name Email Birthday Phone
John Smith 1@1.com 01/01/1960 404-555-1212

So only 1 lead is left. I have alot of these, so an automatic or VBA method would be needed. The phone field would be unique and could be a good merge anchor. Ideas?

 

[Macropod]

Ah, but what happens when you have:
John Smith 1@1.com 404-555-1212
John Smith 2@1.com 404-555-1212
Joan Smith 1@1.com 404-555-1212

 

[mrjjman]

With the leads, only 1 email address would show. But the phone would be the same to use an an anchor merge field

 

[Macropod]

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim lRow As Long, i As Long
With ActiveSheet
  .UsedRange
  lRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
  With .Sort
    With .SortFields
      .Clear
      .Add Key:=Range("E2:E" & lRow), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
      .Add Key:=Range("B2:B" & lRow), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
      .Add Key:=Range("A2:A" & lRow), SortOn:=xlSortOnValues, _
        Order:=xlAscending, DataOption:=xlSortNormal
    End With
    .SetRange Range("A1:E" & lRow)
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  For i = lRow - 1 To 2 Step -1
    If .Range("E" & i).Value = .Range("E" & i + 1).Value Then
      If .Range("A" & i).Value = .Range("A" & i + 1).Value Then
        If .Range("B" & i).Value = .Range("B" & i + 1).Value Then
          If .Range("C" & i).Value = "" Then
            .Range("C" & i).Value = .Range("C" & i + 1).Value
          End If
          If .Range("D" & i).Value = "" Then
            .Range("D" & i).Value = .Range("D" & i + 1).Value
          End If
          .Rows(i + 1).EntireRow.Delete
        End If
      End If
    End If
  Next
End With
Application.ScreenUpdating = True
End Sub