VBA : import data and replace existing contacts

[Céline Brien]

Hi everybody,
The macro codes (see below) from Sue Mosher book create new contacts
from data in an Excel Worksheet.
If you execute it twice, you end up with all those contacts X by 2.
I would like to remplace existing contacts.
Can you propose codes to do that ?
Or codes that would begin by deleting the contacts of the categorie
"Excel contact" ?
Thank you for your help !
Céline
----------------------------------
' ExcelDLToContacts
' Listing 24.4
'-------------------------------------------------------------
' Purpose : Create new contacts from data in an Excel Worksheet
'=============================================================
Sub ExcelDLToContacts()
Dim objExcel As Excel.Application
Dim objWB As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim objRange As Excel.Range
Dim objApp As Outlook.Application
Dim objContact As Outlook.ContactItem
Dim intRowCount As Integer
Dim I As Integer
On Error Resume Next

m_blnWeOpenedExcel = False
Set objExcel = GetObject(, "Excel.Application")
If objExcel Is Nothing Then
Set objExcel = CreateObject("Excel.Application")
m_blnWeOpenedExcel = True
End If
On Error GoTo 0
Set objWB = objExcel.Workbooks.Add("C:\Documents and Settings\Céline
Brien\Mes documents\Outlook 2000\Contacts en Excel.xls")
Set objWS = objWB.Worksheets(1)
Set objRange = objWS.Range("Data")
intRowCount = objRange.Rows.Count
If intRowCount > 0 Then
Set objApp = CreateObject("Outlook.Application")
For I = 1 To intRowCount
Set objContact = objApp.CreateItem(olContactItem)
With objContact
.FirstName = objRange.Cells(I, 2)
.LastName = objRange.Cells(I, 3)
.CompanyName = objRange.Cells(I, 4)
.JobTitle = objRange.Cells(I, 5)
.BusinessAddressStreet = objRange.Cells(I, 6)
.BusinessAddressCity = objRange.Cells(I, 7)
.BusinessAddressState = objRange.Cells(I, 8)
.BusinessAddressPostalCode = objRange.Cells(I, 9)
.BusinessAddressState = objRange.Cells(I, 10)
.BusinessTelephoneNumber = objRange.Cells(I, 11)
.BusinessFaxNumber = objRange.Cells(I, 12)
.Email1Address = objRange.Cells(I, 13)
.Body = objRange.Cells(I, 14)
.Categories = objRange.Cells(I, 15)
.Save
End With
Next
End If
objWB.Close False
Call RestoreExcel

Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing
Set objRange = Nothing
Set objApp = Nothing
Set objContact = Nothing
End Sub
Sub RestoreExcel()
Dim objExcel As Excel.Application
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If m_blnWeOpenedExcel Then
objExcel.Quit
Else
objExcel.Visible = True
End If
Set objExcel = Nothing
End Sub

 

[Eric Legault [MVP - Outlook]]

You have two options:

1) For replacing existing Contacts, you can use the Restrict or Find methods
on the Items collection of the Contacts folder to search for the current
Contact record in the spreadsheet:

Set objItems = objContactItems.Restrict("[Full Name] = 'John Doe'")

If it exists:

Set objContact = objItems(1)
objContact.Delete

2) To search for all Contacts with a specific category and delete them:

Set objItems = objContactItems.Restrict("[Categories] = 'Excel
Contact'")
For intX = 1 to objItems.Count Step -1
Set objItem = objItems(intx)
objItem.Delete
Next

 

[cenky]

Eric, will you please help me to itegrate your solution to my code? I have very well working code to add contact from excel to Outlook, however I am facing same problem as Celine Brien - want to update the contact if already exists (for instance contact which has same emailadress as the one i have in my excel worksheet).

Here is my code:
Sub Add_contact_to_Outlook()

Dim applOutlook As Outlook.Application
Dim nsOutlook As Outlook.Namespace
Dim ciOutlook As Outlook.ContactItem
Dim delFolder As Outlook.Folder
Dim delItems As Outlook.Items
Dim lLastRow As Long, i As Long, n As Long, c As Long

Dim objItems As Outlook.Items
Dim objContact As Outlook.ContactItem

Set applOutlook = New Outlook.Application

Set nsOutlook = applOutlook.GetNamespace("MAPI")

Set ciOutlook = applOutlook.CreateItem(olContactItem)

ciOutlook.Display

With ciOutlook
.FirstName = Sheets("Sheet1").Cells(72, 16)
.LastName = Sheets("Sheet1").Cells(72, 20)
.Email1Address = Sheets("Sheet1").Cells(78, 16)
.MobileTelephoneNumber = Sheets("Sheet1").Cells(76, 16)
.Birthday = Sheets("Sheet1").Cells(24, 13)
End With

ciOutlook.Close olSave

Set applOutlook = Nothing
Set nsOutlook = Nothing
Set ciOutlook = Nothing
Set delFolder = Nothing
Set delItems = Nothing

End Sub