This is a pretty good de-duper based on the one posted to a forum. This one normalizes some data so it’ll match, even if it looks different.
' http://www.hardforum.com/printthread.php?t=854485
' by pbj75
Public Sub deleteDuplicateContacts()
Dim oldcontact As ContactItem, newcontact As ContactItem, j As Integer
Set myNameSpace = GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderContacts)
Set myitems = myfolder.Items
myitems.Sort "[File As]", olDescending
totalcount = myitems.Count
j = 1
While ((j < totalcount) And (myitems(j).Class <> olContact))
j = j + 1
Wend
Set oldcontact = myitems(j)
For i = j + 1 To totalcount
If (myitems(i).Class = olContact) Then
Set newcontact = myitems(i)
If ((newcontact.LastNameAndFirstName = oldcontact.LastNameAndFirstName) And _
(NormPhone(newcontact.PagerNumber) = NormPhone(oldcontact.PagerNumber)) And _
(NormPhone(newcontact.MobileTelephoneNumber) = NormPhone(oldcontact.MobileTelephoneNumber)) And _
(NormPhone(newcontact.HomeTelephoneNumber) = NormPhone(oldcontact.HomeTelephoneNumber)) And _
(NormPhone(newcontact.BusinessTelephoneNumber) = NormPhone(oldcontact.BusinessTelephoneNumber)) And _
(NormAddress(newcontact.BusinessAddress) = NormAddress(oldcontact.BusinessAddress)) And _
(newcontact.Email1Address = oldcontact.Email1Address) And _
(newcontact.HomeAddress = oldcontact.HomeAddress) And _
(newcontact.CompanyName = oldcontact.CompanyName)) Then
'use FTPSite as a flag to mark duplicates
newcontact.FTPSite = "DELETEME"
newcontact.Save
Else
newcontact.FTPSite = ""
newcontact.Save
End If
Set oldcontact = newcontact
End If
Next i
End Sub
Public Function NormPhone(ByVal p As String) As String
' first, replace . with -
p = Replace(p, ".", "-")
' second if the 4th character is "-" then change the format to (nnn) nnn-nnnn
If (Mid(p, 4, 1) = "-") Then
p = "(" & Mid(p, 1, 3) & ") " & Mid(p, 5)
End If
If (Mid(p, 5, 1) = ")" And Mid(p, 6, 1) <> " ") Then
p = Mid(p, 1, 5) & " " & Mid(p, 6)
End If
NormPhone = p
End Function
Public Function NormAddress(ByVal a As String) As String
a = Replace(a, "USA", "")
a = Replace(a, "United States of America", "")
a = RTrim(a)
a = Replace(a, vbCrLf, " ")
a = Replace(a, vbCr, " ")
a = Replace(a, vbLf, " ")
a = Replace(a, " ", " ")
a = Replace(a, " ", " ")
a = Replace(a, " ", " ")
NormAddress = a
End Function