duplicate contacts 1

[christhedonstar]

Hi,

I have an address book in outlook with duplicate entries (name, phone number, details etc the same).I want to get rid of the duplicates. How would I do this without manually checking?

Thanks,

Chris

 

[WinblowsME]

In Outlook, click File -> Import and Export -> Export to a file -> Comma Separated Values (DOS) -> Pick your address book and export as a .csv file.

Open the .csv and run the following macro and save

Sub delete_duplicates()
   Dim i As Long, j As Integer, last_row As Long, same As Boolean
   
   last_row = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).row

   For i = last_row To 2 Step -1
      same = True
      
      For j = 1 To 90
         If Cells(i, j) <> Cells(i - 1, j) Then
            same = False
            Exit For
         End If
      Next j
      
      If same Then
         Range(i & ":" & i).EntireRow.delete
      End If
   Next i
End Sub

In Outlook, click File -> Import and Export -> Import from another program or file -> Comma Separated Values (DOS) -> Look for your .csv file -> Import the contacts into a TEMP folder.

 

[christhedonstar]

Hmm I guess thats one way of doing it .

Is there an outlook method?

 

[WinblowsME]

Backup your contacts before you run the macro! I am not responsible for any damages that may occur.

This macro will delete "duplicate" contacts in the "Contacts folder.

NOTE: This macro considers the contacts to be the same if all of the following fields are the same:

1) Full Name
2) Business Telephone Number
3) Body

'contacts.Items(i)                          :  Full Name
'contacts.Items(i).BusinessTelephoneNumber  :  Business Telephone Number
'contacts.Items(i).body                     :  Body
'contacts.Items(i).Email1Address            :  Email1 -> Might cause an outlook security popup if used

Sub Delete_Duplicate_Contacts()
   Dim ns As Outlook.NameSpace
   Dim contacts As Outlook.MAPIFolder
   Dim i As Integer, j As Integer, same As Boolean
   
   Set ns = GetNamespace("MAPI")
   Set contacts = ns.GetDefaultFolder(olFolderContacts)
   
   On Error Resume Next
   
   For i = contacts.Items.Count To 2 Step -1
      same = False
      
      For j = i - 1 To 1 Step -1
         If contacts.Items(i) = contacts.Items(j) And _
            contacts.Items(i).BusinessTelephoneNumber = contacts.Items(j).BusinessTelephoneNumber And _
            contacts.Items(i).body = contacts.Items(j).body Then                        
            same = True            
            Exit For
         End If
      Next j
      
      If same Then
         Debug.Print "SAME: " & contacts.Items(i) & "," & _
                                contacts.Items(i).BusinessTelephoneNumber & "," & _
                                contacts.Items(i).body
         'Remove comment from next line to delete the contact
         'contacts.Items(i).Delete
      End If
   Next i
   
   Set contacts = Null
   Set ns = Null
   
   MsgBox "Done"
End Sub

 

[WinblowsME]

Revised

Sub Delete_Duplicate_Contacts()
   Dim ns As Outlook.NameSpace
   Dim contacts As Outlook.MAPIFolder
   Dim i As Integer, j As Integer, same As Boolean
   Dim full_name As String, business_phone As String, body As String
   Dim curr_full_name As String, curr_business_phone As String, curr_body As String
   
   Set ns = GetNamespace("MAPI")
   Set contacts = ns.GetDefaultFolder(olFolderContacts)
   
   On Error Resume Next
   
   For i = contacts.Items.Count To 2 Step -1
      full_name = contacts.Items(i)
      business_phone = contacts.Items(i).BusinessTelephoneNumber
      body = contacts.Items(i).body
      same = False
      
      For j = i - 1 To 1 Step -1
         curr_full_name = contacts.Items(j)
         curr_business_phone = contacts.Items(j).BusinessTelephoneNumber
         curr_body = contacts.Items(j).body
      
         If full_name = curr_full_name And _
            business_phone = curr_business_phone And _
            body = curr_body Then
            
            Debug.Print "SAME: " & full_name & "," & business_phone & "," & body
            same = True
            Exit For
         End If
      Next j
      
      If same Then
         'Remove comment from next line to delete the contact
         'contacts.Items(i).Delete
      End If
   Next i
   
   Set contacts = Null
   Set ns = Null
   
   MsgBox "Done"
End Sub

 

[christhedonstar]

Thanks - I've given you a star... I wasn't expecting the full code, so thanks for that. I didn't realise I could have just hit f1 and got the main functions specifically these two lines...
Set ns = GetNamespace("MAPI")
Set contacts = ns.GetDefaultFolder(olFolderContacts)

I changed the code slightly because it was a bit slow iterating over all the contacts. For anyone thats needs the same thing...

Option Explicit
Option Base 1



Sub Delete_Duplicate_Contacts()

Const NAME = 1
Const BUSINESSNUM = 2
Const BODYTEXT = 3
Const HOME = 4


Dim ns As Outlook.NameSpace
Dim contacts As Outlook.MAPIFolder
Dim i As Integer, j As Integer, same As Boolean
Dim full_name As String, business_phone As String, body As String
Dim curr_full_name As String, curr_business_phone As String, curr_body As String
Dim innerContacts() As String

Dim numberOfContacts As Integer

On Error Resume Next



Set ns = GetNamespace("MAPI")
Set contacts = ns.GetDefaultFolder(olFolderContacts)

numberOfContacts = contacts.Items.Count

'put the contacts into an array
ReDim Preserve innerContacts(numberOfContacts, 3)

For i = 1 To numberOfContacts

innerContacts(i, NAME) = contacts.Items(i)
innerContacts(i, BUSINESSNUM) = contacts.Items(i).BusinessTelephoneNumber
innerContacts(i, BODYTEXT) = contacts.Items(i).body
innerContacts(i, HOME) = contacts.Items(i).HOME
Next



For i = contacts.Items.Count To 2 Step -1

full_name = contacts.Items(i)
business_phone = contacts.Items(i).BusinessTelephoneNumber
body = contacts.Items(i).body
same = False

For j = i - 1 To 1 Step -1
curr_full_name = innerContacts(j, NAME)
curr_business_phone = innerContacts(j, BUSINESSNUM)
curr_body = innerContacts(j, BODYTEXT)

If full_name = curr_full_name And _
business_phone = curr_business_phone And _
body = curr_body Then

Debug.Print "SAME: " & full_name & "," & business_phone & "," & body
same = True
Exit For

End If
Next j

If same Then
'Remove comment from next line to delete the contact
contacts.Items(i).Delete
End If
Next i

Set contacts = Null
Set ns = Null

MsgBox "Done"
End Sub