Remove duplicated cells based on a column value BUT not deleting the repeating headers.

Hi,

I have a long spreadsheet with 4 columns which comes like:

Name Age Address Phone Number
M. Li 56 FL 1
J. Jones 43 NJ 2
K. Smith 52 FL 3
J. Jones 43 NJ 2

Name Age Address Phone Number
M. Li 56 FL 1
J. Jones 43 NJ 2
L. Peters 20 ND 4
A. Kate 25 SD 3

Name Age Address Phone Number
K. Car 24 FL 5


and it goes on like this.

What I would need is a macro that would look for the phone number (the forth column) and delete all the duplicates but leaves the header so that the end result would look like:

Name Age Address Phone Number
M. Li 56 FL 1
J. Jones 43 NJ 2
K. Smith 52 FL 3

Name Age Address Phone Number
L. Peters 20 ND 4

Name Age Address Phone Number
K. Car 24 FL 5

Basically what I would need is to have it delete all the duplicates except if it contains "Phone Number". I could get it delete the duplicates but am unable to add a condition to prevent it from deleting the headers (which I need so as to keep my information in block for the distribution of work).

Would be grateful if you could help.

try it

Sub ert()
Dim x, rDel As Range, i&, s$
x = Range("D1", Cells(Rows.Count, 4).End(xlUp)).Value: Set rDel = Range("A1")
On Error Resume Next
With New Collection
    For i = 1 To UBound(x)
        If Len(x(i, 1)) Then
            If Not x(i, 1) Like "Phone*" Then
                s = CStr(x(i, 1))
                If IsEmpty(.Item(s)) Then
                    .Add 1, s
                Else
                    Set rDel = Union(Cells(i, 4), rDel)
End If: End If: End If: Next i: End With
If Not rDel Is Nothing Then Intersect(Columns(4), rDel).EntireRow.Delete
End Sub

Worked perfectly. Absolute genius! Many many thanks.

Worked perfectly. Absolute genius! Many many thanks.