如何修复Excel循环行的VBA代码中的5097错误？

针对你提供的VBA代码运行时出现的5097错误（与Word模板调用、内存问题相关），以下是具体修复方案：

核心问题分析 #

5097错误多因Word资源未及时释放、重复创建应用实例导致内存堆积，或是依赖光标位置的查找替换逻辑不稳定引发。

具体修复步骤 #

• 将Word实例创建移至循环外
  原代码每次循环都新建Word应用，极易造成内存泄漏。应在循环前创建一次Word实例，循环内仅重复打开模板文档，循环结束后再关闭实例。

• 替换Selection.Find为Content.Find
Selection依赖光标位置，容易出现查找替换失效或异常。直接调用文档内容的查找方法，逻辑更稳定可靠。

• 强制保障资源释放
  添加错误捕获机制，确保即使代码执行出错，Word文档、应用实例也能被正确关闭，避免残留进程占用系统资源。

• 优化模板调用方式
  可先将模板复制为临时文件再打开，避免原模板被锁定；同时确认模板路径绝对正确，且未被其他程序占用。

• 调整Outlook邮件处理逻辑
  移除不必要的.Display调用（若无需预览邮件），或添加短暂延迟确保邮件编辑器加载完成后再执行粘贴操作。

优化后的完整代码 #

Sub SendMailnow()
    Dim response As VbMsgBoxResult
    Dim ol As Outlook.Application
    Dim olm As Outlook.MailItem
    Dim wd As Word.Application
    Dim doc As Word.Document
    Dim r As Long
    Dim lastRow As Long
    Dim Editor As Word.Document
    
    response = MsgBox("Do you wish to send out all the reports?", vbYesNo, "Send Reports")
    
    If response = vbYes Then
        ' 仅创建一次Outlook和Word实例
        Set ol = New Outlook.Application
        Set wd = New Word.Application
        wd.Visible = False
        
        lastRow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
        
        ' 错误捕获确保资源释放
        On Error GoTo Cleanup
        
        For r = 13 To lastRow
            Set olm = ol.CreateItem(olMailItem)
            ' 打开模板文档
            Set doc = wd.Documents.Open("C:\Users\ChristopherPierce\Documents\PFC Template.docx")
            
            ' 使用Content.Find替代Selection.Find
            With doc.Content.Find
                .Text = "<<airportname>>"
                .Replacement.Text = Sheet2.Cells(r, 2).Value
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<NPC>>"
                .Replacement.Text = Sheet2.Cells(r, 3).Value
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<TPRC>>"
                .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 4).Value)
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<TPR>>"
                .Replacement.Text = Sheet2.Cells(r, 5).Value
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<TPRR>>"
                .Replacement.Text = FormatCurrency(-1 * Sheet2.Cells(r, 6).Value)
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<NA>>"
                .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 7).Value)
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<CCW>>"
                .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 8).Value)
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<CCR>>"
                .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 9).Value)
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<AA>>"
                .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 10).Value)
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<RA>>"
                .Replacement.Text = FormatCurrency(Sheet2.Cells(r, 11).Value)
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<RD>>"
                .Replacement.Text = Sheet2.Cells(r, 12).Value
                .Execute Replace:=wdReplaceAll
                
                .Text = "<<enddate>>"
                .Replacement.Text = Sheet2.Cells(r, 13).Value
                .Execute Replace:=wdReplaceAll
            End With
            
            doc.Content.Copy
            
            If Sheet2.Cells(r, 14).Value <> "" Then
                With olm
                    .To = Sheet2.Cells(r, 14).Value
                    .CC = Sheet2.Cells(r, 15).Value
                    .Subject = "Breeze Airways PFC Statement - " & Sheet2.Cells(r, 2).Value
                    Set Editor = .GetInspector.WordEditor
                    ' 添加短暂延迟确保编辑器加载
                    Application.Wait Now + TimeValue("00:00:01")
                    Editor.Content.Paste
                    .Send
                End With
            End If
            
            ' 释放当前循环的资源
            doc.Close SaveChanges:=False
            Set doc = Nothing
            Set olm = Nothing
        Next r
        
Cleanup:
        ' 确保所有资源被释放
        If Not doc Is Nothing Then
            doc.Close SaveChanges:=False
            Set doc = Nothing
        End If
        If Not wd Is Nothing Then
            wd.Quit
            Set wd = Nothing
        End If
        If Not ol Is Nothing Then
            Set ol = Nothing
        End If
        Application.DisplayAlerts = True
        
        ' 若有错误，提示错误信息
        If Err.Number <> 0 Then
            MsgBox "执行出错：" & Err.Description, vbCritical
        End If
    End If
End Sub

内容的提问来源于stack exchange，提问作者Chrisapswim