How to fix 5097 error in VBA code to loop through rows in excel?

Question

Every time I run this VBA code, I get a 5097 error. I know it has to do with the Word doc I am pulling as a template, but I don't know how to fix it. Here is my code. I know this could also be a memory issue. If anyone has any ideas on how to fix this, I would love the feedback.

Sub SendMailnow()

response = MsgBox("Do you wish to send out all the reports?", vbYesNo, "Send Reports")
    
If response = vbYes Then

    Set ol = New Outlook.Application
    
    For r = 13 To Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
        Set olm = ol.CreateItem(olMailItem)
        
        Set wd = New Word.Application
        wd.Visible = False
        Set doc = wd.Documents.Open("C:\Users\ChristopherPierce\Documents\PFC Template.docx")
        
        With wd.Selection.Find
            .Text = "<<airportname>>"
            .Replacement.Text = Sheet2.Cells(r, 2).Value
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<NPC>>"
            .Replacement.Text = Sheet2.Cells(r, 3).Value
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<TPRC>>"
            .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 4).Value)
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<TPR>>"
            .Replacement.Text = Sheet2.Cells(r, 5).Value
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<TPRR>>"
            .Replacement.Text = FormatCurrency(-1 * Sheet2.Cells(r, 6).Value)
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<NA>>"
            .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 7).Value)
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<CCW>>"
            .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 8).Value)
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<CCR>>"
            .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 9).Value)
            .Execute Replace:=wdReplaceAll
        End With
        
         With wd.Selection.Find
            .Text = "<<AA>>"
            .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 10).Value)
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<RA>>"
            .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 11).Value)
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<RD>>"
            .Replacement.Text = Sheet2.Cells(r, 12).Value
            .Execute Replace:=wdReplaceAll
        End With
        
        With wd.Selection.Find
            .Text = "<<enddate>>"
            .Replacement.Text = Sheet2.Cells(r, 13).Value
            .Execute Replace:=wdReplaceAll
        End With
        
        doc.Content.Copy
    If Sheet2.Cells(r, 14).Value = "" Then
    Else

        With olm
            .Display
            .To = Sheet2.Cells(r, 14).Value
            .CC = Sheet2.Cells(r, 15).Value
            'Here you can change the subject header
            .Subject = "Breeze Airways PFC Statement -" & " " & Sheet2.Cells(r, 2).Value
            Set Editor = .GetInspector.WordEditor
            Editor.Content.Paste
            .Send
        End With
    End If
    
    Set olm = Nothing
    
    doc.Close SaveChanges:=False
    Set doc = Nothing
    
    wd.Quit
    
    Set wd = Nothing
    Application.DisplayAlerts = True
    
    Next

Else
    End If
    
End Sub

I just need to fix this error. anny ideas?

Answer 1

There are numerous problems with your code, including that is creates and destroys multiple instances of Word and Outlook, with all the overheads that entails, using Selection in Word, with all its inefficiencies and creates documents it then doesn't use. Additionally, one of your variables is defined and you introduce olm without defining it. Try:

Sub SendMailnow()
If MsgBox("Do you wish to send out all the reports?", vbYesNo, "Send Reports") <> vbYes Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.document
Dim olApp As New Outlook.Application, olMl As Outlook.MailItem
Dim xlSht As Excel.Worksheet, r As Long: Set xlSht = Sheet2
For r = 13 To xlSht.Cells(Rows.Count, 1).End(xlUp).Row
  If xlSht.Cells(r, 14).Value <> "" Then
    Set wdDoc = wdApp.Documents.Open("C:\Users\ChristopherPierce\Documents\PFC Template.docx")
    With wdDoc
      With .Range.Find
        .Text = "<<airportname>>"
        .Replacement.Text = xlSht.Cells(r, 2).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<NPC>>"
        .Replacement.Text = xlSht.Cells(r, 3).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<TPRC>>"
        .Replacement.Text = FormatCurrency(xlSht.Cells(r, 4).Value)
        .Execute Replace:=wdReplaceAll
        .Text = "<<TPR>>"
        .Replacement.Text = xlSht.Cells(r, 5).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<TPRR>>"
        .Replacement.Text = FormatCurrency(-1 * xlSht.Cells(r, 6).Value)
        .Execute Replace:=wdReplaceAll
        .Text = "<<NA>>"
        .Replacement.Text = FormatCurrency(xlSht.Cells(r, 7).Value)
        .Execute Replace:=wdReplaceAll
        .Text = "<<CCW>>"
        .Replacement.Text = FormatCurrency(xlSht.Cells(r, 8).Value)
        .Execute Replace:=wdReplaceAll
        .Text = "<<CCR>>"
        .Replacement.Text = FormatCurrency(xlSht.Cells(r, 9).Value)
        .Execute Replace:=wdReplaceAll
        .Text = "<<AA>>"
        .Replacement.Text = FormatCurrency(xlSht.Cells(r, 10).Value)
        .Execute Replace:=wdReplaceAll
        .Text = "<<RA>>"
        .Replacement.Text = FormatCurrency(xlSht.Cells(r, 11).Value)
        .Execute Replace:=wdReplaceAll
        .Text = "<<RD>>"
        .Replacement.Text = xlSht.Cells(r, 12).Value
        .Execute Replace:=wdReplaceAll
        .Text = "<<enddate>>"
        .Replacement.Text = xlSht.Cells(r, 13).Value
        .Execute Replace:=wdReplaceAll
      End With
      .Content.Copy
      With olApp
        Set olMl = .CreateItem
        With olMl
          .Display
          .To = xlSht.Cells(r, 14).Value
          .CC = xlSht.Cells(r, 15).Value
          'Here you can change the subject header
          .Subject = "Breeze Airways PFC Statement - " & xlSht.Cells(r, 2).Value
          .GetInspector.WordEditor.Content.Paste
          .Send
        End With
      End With
      .Close SaveChanges:=False
    End With
  End If
Next
olApp.Quit: wdApp.Quit
Set olMl = Nothing: Set olApp = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing: Set xlSht = Nothing
End Sub