How to remove duplicate contacts from Lookout


    From https://wp.normalchaos.com/wordpress/archives/category/macros

    Instructions

    1. From Outlook, open your macro editor. (Either press alt-F11 or select Tools, Macro, Visual Basic Editor.)
    2. In the macro editor window, select Insert, Module. This will create a text editor window into which you can paste the macro.
    3. In the text editor window, paste in the code below. (I recommend you review the code to be sure it’s doing what you want.)
    4. You can run the code by placing your cursor anywhere in the code window between the “Sub” and “End Sub” statements and pressing F5. Optionally, you can close the Visual Basic window, then select Tools, Macro, Macros…, and “Run” RemoveDuplicateContacts.

    Here is the code for the macro. Hopefully, it is useful to someone. Please let me know if you have any problems so I can correct make an effort to correct the macro.

    IMPORTANT A regular copy/paste should work correctly. However, you may experience issues with line breaks that prevent the macro from working. If this is the case, the Outlook VB editor will make it abundantly clear what lines are invalid, so it should be pretty easy to fix rogue line wrapping.

    ':::::::::::::::::: Macro Begins Here; Copy this line and everything below

Sub RemoveDuplicateContacts()

Dim StatusMessage As String

Dim olApp As Outlook.Application

Dim olContact1 As Outlook.ContactItem

Dim olContact2 As Outlook.ContactItem

Dim olItems As Outlook.Items

Dim olNS As Outlook.NameSpaceSet olApp = New Outlook.Application

Set olNS = olApp.GetNamespace("MAPI")

Set olItems = olNS.GetDefaultFolder(olFolderContacts).Items

olItems.Sort ("File As")

Dim DeleteCount As Integer

Dim z As Integer

DeleteCount = 0

StatusMessage = ""

For z = olItems.Count To 2 Step -1

On Error GoTo GroupFound:

ContinueAfterGroup:

Set olContact1 = olItems.Item(z)

Set olContact2 = olItems.Item(z - 1)

On Error GoTo Error1:

DoEvents

' Check key fields to make sure this is a duplicate

' Compare first and last names, home phone, mobile phone, and

' all 3 e-mail addresses to make sure nothing gets overlooked.

' Assume all other fields are the same or unimportant

If olContact1.FileAs = olContact2.FileAs _

And olContact1.FirstName = olContact2.FirstName _

And olContact1.LastName = olContact2.LastName _

And olContact1.Email1Address = olContact2.Email1Address _

And olContact1.Email2Address = olContact2.Email2Address _

And olContact1.Email3Address = olContact2.Email2Address _

And olContact1.HomeTelephoneNumber = olContact2.HomeTelephoneNumber _

And olContact1.MobileTelephoneNumber = olContact2.MobileTelephoneNumber _

Then

'Determine whether or not addresses exist

If olContact1.MailingAddress = olContact2.MailingAddress _

And olContact1.BusinessAddress = olContact2.BusinessAddress Then

olContact1.Delete

StatusMessage = StatusMessage & "Contact item " & olContact2.FileAs & _

" deleted" & vbCrLf & vbCrLf

Debug.Print "Contact item " & olContact2.FileAs & " deleted"

DeleteCount = DeleteCount + 1

Else

StatusMessage = StatusMessage & "Mailing addresses are not the same for contacts " & _

olContact1.FileAs & "." & vbCrLf & _

"Contact not deleted. You may want to manually update " & _

"the contact information." & vbCrLf & vbCrLf

Debug.Print "Mailing addresses are not the same for contacts " & _

olContact1.FileAs & ". Please investigate."

End If

End If

Next

MsgBox DeleteCount & " duplicate Outlook Contacts have been removed" & _

vbCrLf & vbCrLf & StatusMessage

Exit Sub

GroupFound:

z = z - 1

Resume ContinueAfterGroup:

Error1:

MsgBox "Whoops! Something went horribly wrong (but your contacts are just fine)!"

End Sub

':::::::::::::::::: Macro Ends Here
     

     

     

     

    No questions yet.

    Main Menu