如何修改Excel转Word模板的VBA代码以生成单份多页Word文档

修改核心思路 #

• 原代码每次循环都重新打开Word模板生成独立文档，现在改为仅打开一次模板，在同一个文档内循环填充所有数据
• 每条数据填充完成后插入分页符（最后一条数据无需插入，避免多余空白页）
• 所有数据填充完成后统一保存并关闭文档，而非循环内重复执行保存关闭操作

修改后的完整代码 #

Option Explicit

' 修改为你的文件存储路径
Const FilePath As String = "C:\Users\User\Desktop\"
Dim wd As New Word.Application
Dim PersonCell As Range

Sub CreateSingleWordDocument()
    Dim doc As Word.Document
    wd.Visible = True
    
    Dim PersonRange As Range
    ' 获取所有数据范围（从A4开始到最后一行有效数据）
    Set PersonRange = Range("A4", Range("A4").End(xlDown))
    
    ' 仅打开一次Word模板，作为汇总文档的基础
    Set doc = wd.Documents.Open(FilePath & "Template.docx")
    
    ' 遍历每条数据进行填充
    For Each PersonCell In PersonRange
        ' 填充对应书签的内容
        CopyCell "FirstName", 1
        CopyCell "LastName", 2
        CopyCell "Company", 3
        CopyCell "Address", 4
        
        ' 非最后一条数据时，插入分页符并复制模板格式到新页面
        If PersonCell.Row <> PersonRange.Rows(PersonRange.Rows.Count).Row Then
            wd.Selection.EndKey Unit:=wdStory
            wd.Selection.InsertBreak Type:=wdPageBreak
            ' 复制模板起始区域内容，保证新页面保留原模板的格式和书签
            doc.Bookmarks("\StartOfDoc").Range.Copy
            wd.Selection.Paste
        End If
    Next PersonCell
    
    ' 保存汇总后的文档
    doc.SaveAs2 FilePath & "所有人员信息汇总 (" & Format(Now, "yyyy-mm-dd") & ").docx"
    doc.Close
    wd.Quit
    
    MsgBox "汇总文档已生成在：" & FilePath & "!"
    
    Set doc = Nothing
    Set wd = Nothing
End Sub

Sub CopyCell(BookMarkName As String, ColumnOffset As Integer)
    ' 定位到指定书签并填充对应单元格内容
    wd.Selection.GoTo What:=wdGoToBookmark, Name:=BookMarkName
    wd.Selection.TypeText PersonCell.Offset(0, ColumnOffset).Value
End Sub

关键改动说明 #

1. 模板初始化优化：将模板打开操作移到循环外部，避免重复创建文档对象
2. 分页与格式复用：插入分页符后复制原模板的起始区域内容，确保每个新页面都保留模板的格式和书签结构
3. 统一保存逻辑：所有数据填充完成后一次性保存文档，文件名改为汇总类名称，便于识别
4. 边界处理：判断当前数据是否为最后一条，避免在文档末尾插入多余的空白页

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