Results 1 to 2 of 2

Thread: Copy Excel sheet (contacts) to Outlook Contacts using VBA

  1. #1
    Seeker szchris384's Avatar
    Join Date
    Mar 2014
    Posts
    8
    Articles
    0
    Excel Version
    14.0.7212.5000 32bit

    Copy Excel sheet (contacts) to Outlook Contacts using VBA



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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

  2. #2
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,480
    Articles
    0
    Excel Version
    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.
    Attached Files Attached Files
    Last edited by p45cal; 2014-03-05 at 11:52 PM.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •