无法使用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