How to create a contact in Outlook with Excel data? - excel

Question

I have an Excel sheet that has a list of contact names, company names and email addresses.
I want to export these to Outlook.
I have done some code to delete current entries in a contact folder using VBA from Excel, but when adding a new contact, I am getting a 438 Runtime error.
Code to add a contact:
Sub addnewcontacts()
Dim runoutlook As Outlook.Application
Set runoutlook = CreateObject("Outlook.Application")
Set findnamespace = runoutlook.GetNamespace("MAPI")
Set activefolder = findnamespace.Folders
n = 1
Do Until activefolder.Item(n) = "user#domain.co.uk"
n = n + 1
Loop
Set myfolder = activefolder.Item(n)
Set myfolder2 = myfolder.Folders("Contacts").Folders("CustGBP")
lastrow = Sheets("Data").Range("A" & Sheets("Data").Rows.Count).End(xlUp).Row
For i = 1 To lastrow
Sheets("Sage Data").Activate
If ActiveSheet.Range("C" & i).Value = "" Then
' IT BREAKS AT THIS LINE
Set olitem = myfolder2.CreateItem(olContactItem)
With olitem
.FullName = Trim(Range("A" & i).Value).
.Company = Trim(Range("B" & i).Value)
.Email1Address = Range("G" & i).Value
End With
olitem.Save
End If
Next i
End Sub
Working delete code:
Sub outlookdelete()
Dim runoutlook As Outlook.Application
Set runoutlook = CreateObject("Outlook.Application")
Set findnamespace = runoutlook.GetNamespace("MAPI")
Set activefolder = findnamespace.Folders
n = 1
Do Until activefolder.Item(n) = "user#domain.co.uk"
n = n + 1
Loop
Set myfolder = activefolder.Item(n)
Set myfolder2 = myfolder.Folders("Contacts").Folders("CustGBP")
Do
For Each ContactItem In myfolder2.Items
ContactItem.Delete
Next ContactItem
' this is in as otherwise it would only delete a handful
' each time it ran for some reason
Loop Until myfolder2.Items.Count = 0
End Sub

Answer 1

You have to create the item from the application itself (i.e. your runoutlook Outlook Object) and then move it to the desired folder. Starting at where you encounter the error, you can update your code with the following
// Creates a contact Item in the default Contacts folder
Set olitem = runoutlook.CreateItem(olContactItem)
With olitem
.FullName = Trim(Range("A" & i).Value)
.Company = Trim(Range("B" & i).Value) ' may need to change to "CompanyName"
.Email1Address = Range("G" & i).Value
.Move DestFldr:=myfolder2 // moves the contact to the indicated folder
.Save
End With
As for the deletion of all the contacts, you can try this code instead
Do While myfolder2.Items.Count <> 0
myfolder2.Items.Remove (1)
Loop

Answer 2

This is how I managed to get it working myself
For i = 1 To lastrow
Sheets("Data").Activate
If ActiveSheet.Range("C" & i).Value = "" Then
Set olitem = myfolder2.Items.Add(olContactItem)
With olitem
.FullName = Trim(Range("A" & i).Value)
.CompanyName = Trim(Range("B" & i).Value)
.Email1Address = Range("G" & i).Value
.Save
End With
End If
Application.StatusBar = "Updating Contacts: " & Format(i / lastrow, "Percent") & " Complete"
Next i