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