Create Outlook contacts in bulk using VBA automation

A visitors writes and asks "Do you have any code to read an Excel sheet and update Outlook contacts?"

So I whipped up the following code, and thought I would share it with anyone else who needs to create Outlook contacts in bulk, possibly as part of a larger application, filling in the most popular fields (name, email, company).

(FYI — the code at Export Outlook Contacts to Excel does the reverse.)

First I created a sample worksheet with some dummy information, courtesy of Fake Name Generator.

The columns have to be filled out as follows:

• Column A: First Name
• Column B: Last Name
• Column C: Email Address
• Column D: Company Name
• Column E: Business Telephone
• Column F: Business Fax
• Column G: Home Phone

Row 1 must contain headers. The code assigns the entire block of contact information to an array, then creates a contact from each one. As usual, the function returns a boolean value of TRUE if successful.

Dim bWeStartedOutlook As Boolean

Function CreateContactsFromList() As Boolean
' creates contacts in bulk from Excel worksheet
' Col A: First Name
' Col B: Last Name
' Col C: Email Address
' Col D: Company Name
' Col E: Business Telephone
' Col F: Business Fax
' Col G: Home Phone
' Row 1 should be a header row

On Error GoTo ErrorHandler

Dim lNumRows As Long
Dim lNumCols As Long
Dim lCount As Long
Dim varContactInfo As Variant
Dim olContact As Object ' Outlook.ContactItem
Dim strCurrentFirstName As String
Dim strCurrentLastName As String
Dim strCurrentEmailAddr As String
Dim strCurrentCompany As String
Dim strCurrentBusinessPhone As String
Dim strCurrentBusinessFax As String
Dim strCurrentHomePhone As String

' figure out how big our array needs to be, and size appropriately
lNumRows = Sheet1.Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)).Count
lNumCols = Sheet1.Range(Range("A1"), Range("IV1").End(xlToLeft)).Count
ReDim varContactInfo(1 To lNumRows, 1 To lNumCols)

varContactInfo = Range(Cells(2, 1), Cells(lNumRows + 1, lNumCols))

' get Outlook
Dim olApp As Object ' Outlook.Application
Set olApp = GetOutlookApp

lCount = 1

Do Until lCount = lNumRows

  ' assign variant values to intermediate string varbs
  strCurrentFirstName = varContactInfo(lCount, 1)
  strCurrentLastName = varContactInfo(lCount, 2)
  strCurrentEmailAddr = varContactInfo(lCount, 3)
  strCurrentCompany = varContactInfo(lCount, 4)
  strCurrentBusinessPhone = varContactInfo(lCount, 5)
  strCurrentBusinessFax = varContactInfo(lCount, 6)
  strCurrentHomePhone = varContactInfo(lCount, 7)

  ' CreateItem will create a contact in the default folder
  Set olContact = olApp.CreateItem(2) ' olContactItem

  With olContact
    .FirstName = strCurrentFirstName
    .LastName = strCurrentLastName
    .Email1Address = strCurrentEmailAddr
    .CompanyName = strCurrentCompany
    .BusinessTelephoneNumber = strCurrentBusinessPhone
    .BusinessFaxNumber = strCurrentBusinessFax
    .HomeTelephoneNumber = strCurrentHomePhone
  End With

  olContact.Close 0 ' olSave

  lCount = lCount + 1
Loop

' if we got this far, assume success
CreateContactsFromList = True
GoTo ExitProc

ErrorHandler:
CreateContactsFromList = False

ExitProc:
Set olContact = Nothing
If bWeStartedOutlook Then
  olApp.Quit
End If
Set olApp = Nothing
End Function

Function GetOutlookApp() As Object
On Error Resume Next
  Set GetOutlookApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set GetOutlookApp = CreateObject("Outlook.Application")
    bWeStartedOutlook = True
  End If
On Error GoTo 0
End Function

Sample usage:

Sub test()

Dim success As Boolean

success = CreateContactsFromList

End Sub

And I've uploaded the workbook containing the code and the sample data for you to test out, but don't press F5 or you'll end up with 100 useless new contacts

Download sample workbook