Delete duplicate contacts in Outlook using VBA
July 20, 2010 • JP • No Comments • Rate This Article
• Links to this article
Hey, how else were we going to do it?
Deleting duplicate contacts is a tricky business. How do you decide when a pair of contacts are the same?
Are they duplicates when they have the same name and phone number?
What if one has the home address and the other doesn't?
And what about the endless variations on a contact's name?
Here's one way. The following code loops through the default Contacts folder and checks for another contact with the same full name. If it finds one, you're prompted to delete it.
To look for duplicates, we use the Restrict method, instead of comparing each contact to all the others (which would be very wasteful).
We create a new Items collection consisting of all the contacts with a given full name. If there are more than one, there's a duplicate (according to our criteria). The ancillary functions are used to return a reference to the Contacts folder Items collection.
Dim contactItems As Outlook.Items
Dim contact As Outlook.ContactItem
Dim contactFullName As String
Dim filteredContacts As Outlook.Items
Dim numberOfContacts As Long
Dim i As Long
Set contactItems = GetItems(GetNS(GetOutlookApp), olFolderContacts)
numberOfContacts = contactItems.Count
' loop through contact items folder
For i = numberOfContacts To 1 Step -1
If IsContact(contactItems.Item(i)) Then
Set contact = contactItems.Item(i)
contactFullName = contact.FullName
' check if any other contacts have the same full name
Set filteredContacts = _
contactItems.Restrict("[FullName] = '" & contactFullName & "'")
If Not filteredContacts.Count = 1 Then ' possible dupe
If MsgBox("Duplicate contact found, delete?" & _
vbCrLf & contactFullName, vbYesNo) = vbYes Then
contact.Delete
End If
End If
End If
Next i
End Sub
Function IsContact(itm As Object) As Boolean
IsContact = (TypeName(itm) = "ContactItem")
End Function
Function GetItems(olNS As Outlook.NameSpace, _
folder As OlDefaultFolders) As Outlook.Items
' returns the Items Collection for a given default
' folder and Namespace
Set GetItems = olNS.GetDefaultFolder(folder).Items
End Function
Function GetOutlookApp() As Outlook.Application
' returns reference to native Outlook.Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) _
As Outlook.NameSpace
' returns a Namespace Object to access MAPIFolder objects
Set GetNS = app.GetNamespace("MAPI")
End Function
This code is meant to be used in Outlook and should be placed in a standard module in the Outlook VB IDE. Where do I put my Outlook code?
Outlook ·
Rate This Article:
(No Ratings Yet)
Loading ...What now?
Subscribe To The Blog
Email This Article
Follow Me On Twitter
My Facebook Page
Or just keep reading:
I'm just an average guy who writes VBA code for a living. This is my personal blog. Excel and Outlook are my thing, with a sprinkle of Access and Word here and there. Follow this space if you want to learn more about VBA. Keep Reading »
Previous Post: Which macro shortcut keys do you use?
Next Post: Zip outgoing attachments
Speak Your Mind
Tell us what you're thinking...Certain comments (including first-time comments) are subject to moderation and will not appear immediately. Please view the Comment Policy for more information. To post VBA code in your comment, use tags like this: [cc lang='vb']Code goes here[/cc].