Copy Excel sheet (contacts) to Outlook Contacts using VBA

Option Explicit
Dim bWeStartedOutlook As Boolean




Sub test()
    Dim success As Boolean
    success = CreateContactsFromList
End Sub




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
        '.FullName = strCurrentLastName & ", " & strCurrentFirstName
        .Email1Address = strCurrentEmailAddr
        .CompanyName = strCurrentCompany
        .BusinessTelephoneNumber = strCurrentBusinessPhone
        .BusinessFaxNumber = strCurrentBusinessFax
        .HomeTelephoneNumber = strCurrentHomePhone
      End With
    
      olContact.Close 0 'olSave
      
      lCount = lCount + 1
    Loop
    
    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