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