将Excel单元格值及表格导出至Word的宏故障排查

问题说明 #

需要将Excel中的表格及指定单元格值导出到Word模板的对应书签位置，但当前宏仅能复制表格，无法填充书签对应的单元格值。已在Word中插入目标书签，且已引用「Microsoft Word 16.0 Object Library」，原宏代码如下：

Sub ExcelTablesToWord()

    Dim tbl As Excel.Range
    Dim WordApp As Word.Application
    Dim myDoc As Word.Document
    Dim WordTable As Word.Table
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error GoTo WordDocNotFound
    Set WordApp = CreateObject(class:="Word.Application")
    WordApp.Visible = True
    WordApp.Documents.Open ("D:\Template.docx")
    Set myDoc = WordApp.Documents("D:\Template.docx")
    On Error GoTo 0
    
    With myDoc.Bookmarks("HeaderSubject").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B8").Value
    End With
    With myDoc.Bookmarks("REF_ID").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B4").Value
    End With
    With myDoc.Bookmarks("Date").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B5").Value
    End With
    With myDoc.Bookmarks("PersonName").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B7").Value
    End With
    With myDoc.Bookmarks("MainSubject").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B8").Value
    End With
    
    Set tbl = ThisWorkbook.Worksheets("Testing").Range("A14:G41")
    tbl.Copy
    
    'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
    myDoc.Bookmarks("table").Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False
    
    With myDoc.Bookmarks("T_C").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B10").Value
    End With
    
    
    'Completion Message
    MsgBox "Copy/Pasting Complete!", vbInformation
    GoTo EndRoutine
    
    'ERROR HANDLER
WordDocNotFound:
    MsgBox "Microsoft Word file 'Excel Table Word Report.docx' is not currently open, aborting.", 16
    
    'Put Stuff Back The Way It Was Found
EndRoutine:
    'Optimize Code
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    'Clear The Clipboard
    Application.CutCopyMode = False

End Sub

错误原因 #

原代码中With语句的语法错误是导致单元格值无法填充的核心问题：

• With语句的正确用法是先指定目标对象，再在With块内操作该对象的属性或方法，而不是直接在With后面赋值。原代码中的With [对象].属性 = 值写法不符合VBA语法，这些赋值语句实际并未执行。

修正后的代码 #

Sub ExcelTablesToWord()

    Dim tbl As Excel.Range
    Dim WordApp As Word.Application
    Dim myDoc As Word.Document
    Dim WordTable As Word.Table
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error GoTo WordDocNotFound
    Set WordApp = New Word.Application ' 已引用Word库，用New更规范
    WordApp.Visible = True
    ' 打开文档后直接赋值给myDoc，避免路径查找的潜在问题
    Set myDoc = WordApp.Documents.Open("D:\Template.docx")
    On Error GoTo 0
    
    ' 直接为书签对应的Range赋值，无需多余With语句
    myDoc.Bookmarks("HeaderSubject").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B8").Value
    myDoc.Bookmarks("REF_ID").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B4").Value
    myDoc.Bookmarks("Date").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B5").Value
    myDoc.Bookmarks("PersonName").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B7").Value
    myDoc.Bookmarks("MainSubject").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B8").Value
    
    Set tbl = ThisWorkbook.Worksheets("Testing").Range("A14:G41")
    tbl.Copy
    
    ' 粘贴表格到书签位置
    myDoc.Bookmarks("table").Range.PasteExcelTable _
        LinkedToExcel:=False, _
        WordFormatting:=False, _
        RTF:=False
    
    myDoc.Bookmarks("T_C").Range.Text = ThisWorkbook.Worksheets("Testing").Range("B10").Value
    
    ' 完成提示
    MsgBox "复制/粘贴完成！", vbInformation
    GoTo EndRoutine
    
    ' 错误处理
WordDocNotFound:
    MsgBox "未找到Word模板文件'D:\Template.docx'，程序终止。", vbCritical
    
EndRoutine:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.CutCopyMode = False
    ' 可选：若无需保留Word实例，可添加WordApp.Quit（按需选择）
    ' Set WordApp = Nothing
    ' Set myDoc = Nothing

End Sub

额外优化说明 #

1. Word实例创建：已引用Word库时，使用New Word.Application比CreateObject更规范，还能获得代码提示支持。
2. 文档对象赋值：打开文档后直接将返回值赋值给myDoc，避免通过路径查找文档可能出现的重名问题。
3. 错误提示修正：原错误提示文件名与实际打开的模板不符，已修正为正确路径，避免误导。

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