無法使用Excel中的VBA在Outlook中創建聯繫人

Question

我有一張Excel表格，其中包含聯繫人姓名，公司名稱和電子郵件地址列表。我想要做的就是通過VBA將這些內容導入到Outlook中。我已經做了一些代碼，使用Excel中的VBA刪除聯繫人文件夾中的當前條目，但是當添加新聯繫人時，我得到了438運行時錯誤。以下是我正在運行的用於添加聯繫人的代碼，以下是我的工作刪除代碼。

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 
Set olitem = myfolder2.CreateItem(olContactItem) //IT BREAKS AT THIS LINE 
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 

和工作刪除代碼：

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 
Loop Until myfolder2.Items.Count = 0 //this is in as otherwise it would only delete a handful each time it ran for some reason 
End Sub 

任何想法？將使我的工作更容易，而不必每次都進行自定義導入！

乾杯

本

Answer 1

你必須創建應用程序本身（即您runoutlook Outlook對象）的項目，然後將其移動到所需的文件夾。在這裏你會遇到的錯誤開始，你可以更新以下

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

至於所有聯繫人刪除你的代碼，你可以試試這個代碼，而不是

Do While myfolder2.Items.Count <> 0 
    myfolder2.Items.Remove (1) 
Loop 

Answer 2

我這是怎麼管理讓它工作我自己

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