Цикл VBA для перехода по списку рассылки и отправки правильного вложения

Question

Я уверен, что это что-то простое, код ниже работает для первой записи в списке, но не зацикливается, я буквально не могу понять это

Может кто-нибудь пролить свет на исправление этого цикла, пожалуйста?

Я попытался переместить цикл внутри раздела «С OutMail», я попытался выполнить цикл do while.

Sub Send_Emails()

    Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
    Dim OutMail As Object: Set OutMail = OutApp.CreateItem(0)
    Dim r As Range
    Dim rCell As Range
    Dim path As String
    Dim rows As Integer

    Set r = ActiveWorkbook.Sheets("Distribution List").UsedRange

    'Row = Sheets("Distribution List").rows.count   

     'Send Email  

    For i = 2 To 20
    With OutMail   
      att = r(i, 2).Value
      em1 = r(i, 3).Value
      em2 = r(i, 4).Value
      path = "\\azfs\YFHPublic\Farms Project\Holds By Area\Holds by Area" & "\" & att

     On Error Resume Next:
       .SentOnBehalfOfName = "email@email.com"
       .To = em1
       .Subject = "invoices on hold"
       .Body = "this is a test"
       .Attachments.Add path

       .Display
       .Send
        End With

        OutMail = Nothing
        OutApp = Nothing

        i = i + 1     
    Next i

     '  OutMail = Nothing
     '   OutApp = Nothing
End Sub

Answer 1

Я полагаю, вы пытаетесь создать новое электронное письмо для каждого человека в цикле ...

Sub Send_Emails()

    Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
    Dim OutMail As Object 'REMOVED SET FROM HERE
    Dim r As Range
    Dim rCell As Range
    Dim path As String
    Dim rows As Integer

    Set r = ActiveWorkbook.Sheets("Distribution List").UsedRange

    'Row = Sheets("Distribution List").rows.count   

     'Send Email  

    For i = 2 To 20
        Set OutMail = OutApp.CreateItem(0) 'MOVED TO CREATE NEW MAILITEM FOR EACH LOOP
        With OutMail   
            'OTHER CODE