0

連絡先名、会社名、電子メール アドレスのリストを含む Excel シートがあります。

これらを 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

        ' 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

作業削除コード:

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
4

2 に答える 2

0

これは私が自分でそれを機能させることができた方法です

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
于 2013-08-22T14:26:32.560 に答える