Copy Excel sheet (contacts) to Outlook Contacts using VBA

szchris384

New member
Joined
Mar 2, 2014
Messages
8
Reaction score
0
Points
0
Excel Version(s)
16.0.12827.20235 64bit
Looking to copy a sheet of Contacts in Excel to a specific Contact folder in Outlook use VBA


I've found this code and it works for the default Contact folder in Outlook.
I'm wanting to be able to SELECT what Contact folder it imports into (not use the default).


Any help would be appreciated.
I'm using Outlook 2010.


Thanks
Chris

Code:
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
 

p45cal

Super Moderator
Staff member
Joined
Dec 16, 2012
Messages
2,199
Reaction score
16
Points
38
Excel Version(s)
365
I've had an explore (I'm not overly familiar with the Outlook object model). See the attached which works here. There's a button on the sheet which runs a macro which brings up a user form that hopefully only shows the names of folders containing contacts. You should select one of these and then press the only button on the userform. That's it. The code's messy (trial and error). No checks are made you've actually selected something, nothing checks that at least one folder has been found.
It's only put forward to get you on your way to a solution.

ps. SHould there be a problem differentiating folders which have the sae names but are in a different branch of the folder tree structure, a tweak to the code will allow the path to that folder to be shown in the userform; come back if it's needed.
 

Attachments

  • ExcelGuru2734.xlsm
    29.3 KB · Views: 103
Last edited:
Top