複数の受信者への電子メールがエラーハンドラで破損する

Question

標準コードを使用して複数の受信者に電子メールを送信しようとしていますが、モデルで発生する可能性のあるエラー処理が組み込まれています。

電子メールアドレスが利用できない場合、電子メールアドレスが見つかるセルは「保留検索...」と表示されます。

ループの場合は、そのセルをスキップして次の電子メールアドレスに移動するだけで済みます。

以下は私のコードです。この問題は、IF/Then/Next行から発生しています。次のエラーなしで次のエラーが表示されます。どんな入力も非常に高く評価されます。

Sub Mail_workbook_Outlook_1() 


    Dim OutApp As Object 
    Dim OutMail As Object 
    Dim Position_In_Loop As Long 
    Dim Total_Emails As Long 
    Dim Email_Address As String 
    Dim Dashboard As Worksheet 
     Set Dashboard = ActiveWorkbook.Worksheets("Dashboard") 
    Dim Body As Range 
     Set Body = Dashboard.Range("F13") 
    Dim Attachment As Range 
     Set Attachment = Dashboard.Range("F24") 


    With Dashboard 
      Total_Emails = Dashboard.Range("G3") 
    End With 

    For Position_In_Loop = 1 To Total_Emails 

     Email_Address = Dashboard.Range("C3").Offset(Position_In_Loop, 0) 

     If Email_Address = "Pending Search..." Then Next Position_In_Loop 

     Set OutApp = CreateObject("Outlook.Application") 
     Set OutMail = OutApp.CreateItem(0) 

      On Error Resume Next 
       With OutMail 
        .To = "Email_Address" 
        .CC = "" 
        .BCC = "" 
        .Subject = "Open Job Violations" 
        .Body = "Body" 
        .Attachments.Add (Attachment) 
        .Send 
       End With 
      On Error GoTo 0 

     Set OutMail = Nothing 
     Set OutApp = Nothing 

    Next Position_In_Loop 


End Sub 

Answer 1

にこのライン If Email_Address = "Pending Search..." Then Next Position_In_Loop あなたはそのようなループをインクリメントするべきではありません。あなたは電子メールをスキップします。 Outlookのメールコード全体をIf文で囲みます。 Option Explicit

Sub Mail_workbook_Outlook_1() 


    Dim OutApp As Object 
    Dim OutMail As Object 
    Dim Position_In_Loop As Long 
    Dim Total_Emails As Long 
    Dim Email_Address As String 
    Dim Dashboard As Worksheet 
    Set Dashboard = ActiveWorkbook.Worksheets("Dashboard") 
    Dim Body As Range 
    Set Body = Dashboard.Range("F13") 
    Dim Attachment As Range 
    Set Attachment = Dashboard.Range("F24") 

    With Dashboard 
     Total_Emails = Dashboard.Range("G3") 
    End With 

    For Position_In_Loop = 1 To Total_Emails 

     Email_Address = Dashboard.Range("C3").Offset(Position_In_Loop, 0) 

     If Email_Address <> "Pending Search..." Then 

      Set OutApp = CreateObject("Outlook.Application") 
      Set OutMail = OutApp.CreateItem(0) 

      On Error Resume Next 
      With OutMail 
       .To = "Email_Address" 
       .CC = "" 
       .BCC = "" 
       .Subject = "Open Job Violations" 
       .Body = "Body" 
       .Attachments.Add Attachment 
       .Send 
      End With 
      On Error GoTo 0 

      Set OutMail = Nothing 
      Set OutApp = Nothing 
     End If 
    Next Position_In_Loop 


End Sub 

Answer 2

変更

If Email_Address = "Pending Search..." Then 
Position_In_Loop=Position_In_Loop+1 
end if