Loop to next when there is no attachment to be added to an email

Question

I have code to send bulk emails to different recipients and with two attachments.
One PDF and one Excel file is attached to each mail, when available.

When the macro does not find the PDF or Excel that it should attach, it sends the email without any attachment.

I would like to skip/delete emails when no attachment is found.
If only the PDF or only the Excel, then it is fine.

I need to skip to the next email without sending the current one, if the current one has no attachment.

Option Explicit
Public Sub SendScorecards()
    Dim olApp As Object
    Dim olMail As Object
    Dim olRecip As Object
    Dim olAtmt As Object
    Dim olAtmt2 As Object
    Dim iRow As Long
    Dim Recip As String
    Dim Subject As String
    Dim Atmt As String
    Dim Atmt2 As String
    
    iRow = 2
    
    Set olApp = CreateObject("Outlook.Application")
    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("Sender")
    
    Do Until IsEmpty(Sht.Cells(iRow, 1))
    
        Recip = Sht.Cells(iRow, 1).Value 'Email addresses
        Subject = Sht.Cells(iRow, 2).Value 'Subject of the email, like "UK_Vendor name_Operations Scorecard"
        Atmt = Sht.Cells(iRow, 3).Value 'PDF attachment path
        Atmt2 = Sht.Cells(iRow, 4).Value 'Excel attachment path
    
        Set olMail = olApp.CreateItem(0)
    
        With olMail
            Set olRecip = .Recipients.Add(Recip)
            .Subject = Subject
            .Body = Sht.Cells.Range("J2") 'Blurb to be added in the body of the emails
            .Display
            Set olAtmt = .Attachments.Add(Atmt)
            Set olAtmt2 = .Attachments.Add(Atmt2)
            olRecip.Resolve
            .Send
        End With

        On Error Resume Next
        iRow = iRow + 1
    
    Loop
    
    Set olApp = Nothing
End Sub

RobertBaron RobertBaron · Accepted Answer · 2019-05-23T12:51:21

You should check whether the attachment files exist. See this answer. You can then decide to send or not the email.

Here is how your code should look like (only the Do loop, you need to keep the code before and after the loop unchanged). I added the if statement that will skip over rows where both attachment files do not exist, or equivalently, send an email if either or both attachments exist. I did not test that code. If it does not run let me know.

Do Until IsEmpty(Sht.Cells(iRow, 1))

   Recip = Sht.Cells(iRow, 1).Value 'Email addresses
   Subject = Sht.Cells(iRow, 2).Value 'Subject of the email, like "UK_Vendor name_Operations Scorecard"
   Atmt = Sht.Cells(iRow, 3).Value 'PDF attachment path
   Atmt2 = Sht.Cells(iRow, 4).Value 'Excel attachment path

   If Dir(Atmt) <> "" Or Dir(Atmt2) <> "" Then

      Set olMail = olApp.CreateItem(0)
      With olMail
         Set olRecip = .Recipients.Add(Recip)
         .Subject = Subject
         .Body = Sht.Cells.Range("J2") 'Blurb to be added in the body of the emails
         .Display
         Set olAtmt = .Attachments.Add(Atmt)
         Set olAtmt2 = .Attachments.Add(Atmt2)
         olRecip.Resolve
         .Send
      End With

   End If

   On Error Resume Next
   iRow = iRow + 1
Loop

Loop to next when there is no attachment to be added to an email

1 Answers