编写Excel与Word交互VBA代码遇阻，现有代码运行故障求助

需要实现以下VBA功能：

• 打开对话框选择C:\Add-in\Company A\Templates路径下的docx格式Word文件
• 确认名为「Checklist - Navette」的文件已打开，将其中的Navette工作表设为活动表；若未打开则弹出提示「ERROR Please push the comand checklist first」并退出宏
• 使用Navette工作表中与书签同名的单元格内容填充Word文件的所有书签
• 若Navette工作表中「Civilité」单元格内容为「Female」，则打开C:\Add-in\Mapping.xlsx的Replace工作表，将Word文件中A列的所有内容替换为B列内容；否则替换为C列内容
• 打开对话框选择保存路径，将Word文件以「TEST」为名同时保存为docx和PDF格式
• 不保存关闭初始选择的Word文件
• 退出所有应用程序

原代码执行时卡住，无法正常运行：

Sub TestProcess()

'Initial process
    Dim fd As FileDialog
    Dim strFile As String
    Dim wdDoc As Document
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    Dim SaveAsFileName As String
    Dim SaveAsFileFormat As Integer
    
'Dialog box to pickup the docx file
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .InitialFileName = "C:\Add-in\Company\Templates"
        .Filters.Add "Word Files", "*.docx", 1
        If .Show = -1 Then
            strFile = .SelectedItems(1)
        End If
    End With
    
    Set wdDoc = Documents.Open(strFile)
    
'Identify the checklist
    On Error Resume Next
    Set wb = Workbooks("Company - Navette.xlsx")
    On Error GoTo 0

'Handling with errors
    If wb Is Nothing Then
        MsgBox "ERROR 'Please select the command *Open Navette*first"
        wdDoc.Close
        Set wdDoc = Nothing
        Exit Sub
    End If

'Active Worksheet
    On Error Resume Next
    Set ws = wb.Sheets("Navette")
    On Error GoTo 0
    
    'Handling with errors
    If ws Is Nothing Then
        MsgBox "Sheet 'Navette' not found in the workbook."
        
        'For each Bookmark equal name cell replace with the content
        
        For Each wdBookmark In wdDoc.Bookmarks
            wdBookmark.Range.Text = ws.Range(wdBookmark.Name).Value
        Next
        
        
        'Save file
        'Open a dialog box to input the path to save the Word file
        SaveAsFileName = Application.GetSaveAsFilename(FileFilter:="Word Files (*.docx), .docx; PDF Files (.pdf), *.pdf", Title:="Save As", InitialFileName:=strFile)
        
        'Check if a file name and format are selected
        If SaveAsFileName <> "False" Then
            'Determine the selected file format
            If Right(SaveAsFileName, 4) = ".pdf" Then
                SaveAsFileFormat = 17
            Else
                SaveAsFileFormat = 0
            End If
            'Save the file in the selected format
            objDoc.SaveAs SaveAsFileName, FileFormat:=SaveAsFileFormat
        End If
        
        'Close Doc & Excel
        wdDoc.Close
        wb.Close
        
        'Reset the documents
        Set wdDoc = Nothing
        Set wb = Nothing
        Exit Sub
    End If
    
End Sub

原代码核心错误 #

1. 路径与文件名不匹配：初始文件路径写成了C:\Add-in\Company\Templates，与需求的C:\Add-in\Company A\Templates不符；工作簿名称使用了「Company - Navette.xlsx」，但需求是「Checklist - Navette」
2. 逻辑完全颠倒：当找不到Navette工作表时，反而执行填充书签的操作，正确逻辑应该是找到工作表后才执行后续步骤
3. 未声明变量：循环中的wdBookmark、保存时的objDoc均未定义，会触发运行时错误
4. 保存逻辑不符合需求：仅支持单格式保存，未实现同时保存docx和PDF的要求
5. 核心替换功能缺失：完全没有实现根据「Civilité」值替换Word内容的逻辑
6. 异常处理不完善：未处理用户取消文件选择的情况；关闭文件时未指定不保存参数，会弹出保存提示
7. 收尾逻辑缺失：没有实现退出Word和Excel应用程序的代码

修正后的完整代码 #

Sub TestProcess()
    '声明所有变量
    Dim fd As FileDialog
    Dim strFile As String
    Dim wdDoc As Document
    Dim navetteWB As Workbook
    Dim navetteWS As Worksheet
    Dim mappingWB As Workbook
    Dim mappingWS As Worksheet
    Dim savePath As String
    Dim wdBookmark As Bookmark
    Dim replaceRow As Long
    Dim replaceCol As Integer
    
    '1. 打开对话框选择Word模板文件
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .InitialFileName = "C:\Add-in\Company A\Templates\"
        .Filters.Add "Word Files", "*.docx", 1
        .Title = "Select Word Template"
        '处理用户取消选择的情况
        If .Show <> -1 Then
            MsgBox "No file selected. Exiting."
            Exit Sub
        End If
        strFile = .SelectedItems(1)
    End With
    
    '打开选中的Word文件
    Set wdDoc = Documents.Open(strFile)
    
    '2. 检查「Checklist - Navette」工作簿是否打开
    On Error Resume Next
    Set navetteWB = Workbooks("Checklist - Navette.xlsx")
    On Error GoTo 0
    
    If navetteWB Is Nothing Then
        MsgBox "ERROR Please push the comand checklist first"
        wdDoc.Close SaveChanges:=wdDoNotSaveChanges
        Set wdDoc = Nothing
        Exit Sub
    End If
    
    '检查Navette工作表是否存在
    On Error Resume Next
    Set navetteWS = navetteWB.Sheets("Navette")
    On Error GoTo 0
    
    If navetteWS Is Nothing Then
        MsgBox "Sheet 'Navette' not found in the workbook."
        wdDoc.Close SaveChanges:=wdDoNotSaveChanges
        navetteWB.Close SaveChanges:=False
        Set wdDoc = Nothing
        Set navetteWB = Nothing
        Exit Sub
    End If
    
    '3. 用Excel单元格内容填充Word书签
    For Each wdBookmark In wdDoc.Bookmarks
        '检查Excel中是否存在同名单元格
        If Not navetteWS.Range(wdBookmark.Name) Is Nothing Then
            wdBookmark.Range.Text = navetteWS.Range(wdBookmark.Name).Value
        End If
    Next wdBookmark
    
    '4. 根据Civilité值执行文本替换
    If UCase(navetteWS.Range("Civilité").Value) = "FEMALE" Then
        replaceCol = 2 'B列
    Else
        replaceCol = 3 'C列
    End If
    
    '打开Mapping.xlsx
    On Error Resume Next
    Set mappingWB = Workbooks.Open("C:\Add-in\Mapping.xlsx")
    On Error GoTo 0
    
    If mappingWB Is Nothing Then
        MsgBox "Mapping.xlsx not found at C:\Add-in\"
    Else
        Set mappingWS = mappingWB.Sheets("Replace")
        '遍历替换表的A列内容
        For replaceRow = 1 To mappingWS.Cells(mappingWS.Rows.Count, 1).End(xlUp).Row
            If mappingWS.Cells(replaceRow, 1).Value <> "" Then
                With wdDoc.Content.Find
                    .Text = mappingWS.Cells(replaceRow, 1).Value
                    .Replacement.Text = mappingWS.Cells(replaceRow, replaceCol).Value
                    .Forward = True
                    .Wrap = wdFindContinue
                    .MatchCase = False
                    .Execute Replace:=wdReplaceAll
                End With
            End If
        Next replaceRow
        '关闭Mapping工作簿，不保存
        mappingWB.Close SaveChanges:=False
    End If
    
    '5. 选择保存路径并保存为docx和PDF
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "Select Save Folder"
        If .Show <> -1 Then
            MsgBox "No save path selected. Exiting."
            wdDoc.Close SaveChanges:=wdDoNotSaveChanges
            navetteWB.Close SaveChanges:=False
            Exit Sub
        End If
        savePath = .SelectedItems(1) & "\"
    End With
    
    '保存为docx
    wdDoc.SaveAs2 Filename:=savePath & "TEST.docx", FileFormat:=wdFormatXMLDocument
    '保存为PDF
    wdDoc.ExportAsFixedFormat OutputFileName:=savePath & "TEST.pdf", ExportFormat:=wdExportFormatPDF
    
    '6. 不保存关闭初始Word文件
    wdDoc.Close SaveChanges:=wdDoNotSaveChanges
    
    '7. 退出所有应用程序
    navetteWB.Close SaveChanges:=False
    '退出Word
    Application.Quit
    '如果是Excel中运行的宏，取消注释下面一行退出Excel
    'Excel.Application.Quit
End Sub

补充说明 #

• 若代码在Excel中运行，需添加对Word对象库的引用（工具→引用→勾选Microsoft Word xx.x Object Library）
• 若在Word中运行，需添加对Excel对象库的引用（工具→引用→勾选Microsoft Excel xx.x Object Library）
• 所有路径需确保实际存在，否则会触发文件找不到的错误

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