批量制作通知书、合同、文档等——开箱即用的 Word 宏代码

• 准备 Word 模板文档（里面用 {占位符} 标记，例如：{姓名} {身份证号}）
• 准备 Excel 数据表格（第一行是表头，必须和 Word 占位符名称完全一致）
• 打开你的 Word 模板 → 按 Alt + F11 打开宏编辑器

Sub 批量生成Word文档()

    ‘==================================================

    ‘ 修复：对象变量未设置 / ThisDocument.Copy 错误

    ‘ 适用：通知书、合同、证明、授权书等批量生成

    ‘==================================================

    ‘===== 请修改这里 =====

    Const ExcelPath = “C:\Users\86139\Desktop\杂货店\数据.xlsx”

    Const SavePath = “C:\Users\86139\Desktop\杂货店\生成结果\”

    Const SheetName = “Sheet1”

    Dim ExcelApp As Object

    Dim wb As Object

    Dim ws As Object

    Dim newDoc As Document

    Dim i As Long, lastRow As Long

    Dim fileName As String

    ‘错误处理

    On Error GoTo ErrHandle

    ‘创建目录

    If Dir(SavePath, vbDirectory) = “” Then MkDir SavePath

    ‘打开Excel

    Set ExcelApp = CreateObject(“Excel.Application”)

    ExcelApp.Visible = False

    Set wb = ExcelApp.Workbooks.Open(ExcelPath)

    Set ws = wb.Sheets(SheetName)

    ‘获取行数

    lastRow = ws.Cells(ws.Rows.Count, 1).End(-4162).Row

    If lastRow < 2 Then

        MsgBox “Excel无数据”

        GoTo Clean

    End If

    ‘循环生成

    For i = 2 To lastRow

        ‘基于当前模板新建文档

        Set newDoc = Documents.Add(Template:=ThisDocument.FullName, NewTemplate:=False)

        ‘替换内容

        Call ReplaceAll(newDoc, “{姓名}”, ws.Cells(i, 1).Value)

        Call ReplaceAll(newDoc, “{身份证号}”, ws.Cells(i, 2).Value)

        Call ReplaceAll(newDoc, “{电话号码}”, ws.Cells(i, 3).Value)

        ‘保存

        fileName = SavePath & ws.Cells(i, 1).Value & “_通知书.docx”

        newDoc.SaveAs2 fileName, 12

        newDoc.Close wdDoNotSaveChanges

        Application.StatusBar = “完成：” & i – 1 & “/” & lastRow – 1

    Next i

    MsgBox “? 生成完成：” & lastRow – 1 & “份”

Clean:

    On Error Resume Next

    wb.Close False

    ExcelApp.Quit

    Set ws = Nothing

    Set wb = Nothing

    Set ExcelApp = Nothing

    Exit Sub

ErrHandle:

    MsgBox “出错：” & Err.Description & vbCrLf & “错误行：” & Erl

    Resume Clean

End Sub

‘全文替换函数

Private Sub ReplaceAll(doc As Document, findStr As String, replaceStr As String)

    With doc.Content.Find

        .ClearFormatting

        .Replacement.ClearFormatting

        .Text = findStr

        .Replacement.Text = replaceStr

        .MatchWholeWord = True

        .Execute Replace:=wdReplaceAll

    End With

End Sub

• 数字 1 = Excel 第 1 列
• 数字 2 = Excel 第 2 列

4、运行方法

1. 按 Alt + F11 回到 Word
2. 按 Alt + F8
3. 选择 批量生成 Word 文档 → 点击「执行」