CODEWITHSUNDEEP
excelvbaoutlook
bmgh1985
bmgh1985

Reputation: 789

How to create a contact in Outlook with Excel data?

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) = "[email protected]"
        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) = "[email protected]"
        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

Upvotes: 0

Views: 2080

Answers (2)

Jaycal
Jaycal

Reputation: 2087

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

Upvotes: 1

bmgh1985
bmgh1985

Reputation: 789

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

Upvotes: 0

Related Questions