Sub UpdateOLContacts()
'set reference to MS Outlook 11 Library
Dim r As Range, varrDetails As Variant, i As Long, strFullName As String
Dim appOutlook As Outlook.Application, nms As Outlook.Namespace
Dim fldContacts As Outlook.Folder, con As Outlook.ContactItem
'have outlook running when you run this code!
'Set outlook objects:
Set appOutlook = GetObject(, "Outlook.Application")
Set nms = appOutlook.GetNamespace("MAPI")
Set fldContacts = nms.GetDefaultFolder(olFolderContacts)
'set worksheet range (header in row 1 - important to use exactly the specified format):
Set r = Range("A2:O" & Cells(Rows.Count, "A").End(xlUp).Row)
'copy range r values
varrDetails = r.Value
'add/amend contacts:
On Error Resume Next
For i = 1 To UBound(varrDetails, 1) Step 1
strFullName = varrDetails(i, 1) & " " & varrDetails(i, 2)
'find existing contact:
Set con = fldContacts.Items(strFullName)
'check if contact already exists, add a new one if not:
If con.FullName <> strFullName Then
Set con = fldContacts.Items.Add
End If
'add/amend contact details:
With con
.FirstName = varrDetails(i, 1)
.LastName = varrDetails(i, 2)
.JobTitle = varrDetails(i, 3)
.BusinessAddressStreet = varrDetails(i, 4)
.BusinessAddressCity = varrDetails(i, 5)
.BusinessAddressState = varrDetails(i, 6)
.BusinessAddressPostalCode = varrDetails(i, 7)
.BusinessAddressCountry = varrDetails(i, 8)
.CompanyName = varrDetails(i, 9)
.Email1Address = varrDetails(i, 10)
.BusinessTelephoneNumber = varrDetails(i, 11)
.BusinessFaxNumber = varrDetails(i, 12)
.MobileTelephoneNumber = varrDetails(i, 13)
.NickName = varrDetails(i, 14)
.Body = varrDetails(i, 15)
.Close (olSave)
End With
Next i
On Error GoTo 0
Set fldContacts = Nothing
Set nms = Nothing
Set appOutlook = Nothing
End Sub
