MS Outlook: Remove Duplicate Contacts

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