根据EXCEL数据自动生成WORD文档

柚西

很多时候，您是否有过在WORD里面重复制作某种资料的工作。比如给定了合同模板，需要根据不同合同内容制作出不同的合同，但模板是一样的。一般情况下就是老老实实的一份一份的去填写（还不保证不会有错误）。那么有没有可以自动生完成的办法呢？答案是肯定有，不然我在这哔哔啥呢！接下来言归正传。在此上个大招，接下来就以合同为例：
1、制作合同模板文件，把合同变量部分用特殊变量替换。图示如下：


2、在EXCEL里面添加合同主要内容数据，图示如下：


3、在EXCEL里面添加一个Active X按钮控件，根据自身需要修改其属性。


4、打开VBA编辑器，添加项目引用。
具体操作过程为：选择“工具”—“引用”，然后打开加载文件选择框，选择“Microsoft Word16.0 Object Library”这个项目，如下图：


    在此，特别需要说明，Word项目这个必须引用起来，否则后期在执行变量替换时，VBA无法调用Word替换功能。
5、在按钮控件下写如下代码，并将该EXCEL文件另存为XLSM：
   Private Sub cmd_makedoc_Click()
On Error GoTo Err_cmdExportToWord_Click
    Dim objApp As Object 'Word.Application
    Dim objDoc As Object 'Word.Document
    Dim strTemplates As String '模板文件路径名
    Dim strFileName As String '将数据导出到此文件
    Dim i As Integer
    Dim contact_NO As String
    Dim side_A As String
    Dim side_B As String
    i = ActiveCell.Row
    contact_NO = Cells(i, 1)
    side_A = Cells(i, 2)
    side_B = Cells(i, 3)

    With Application.FileDialog(msoFileDialogFilePicker)
         .Filters.Add "word文件", "*.doc*", 1
         .AllowMultiSelect = False
         If .Show Then strTemplates = .SelectedItems(1) Else Exit Sub
    End With

  '通过文件对话框生成另存为文件名
    With Application.FileDialog(msoFileDialogSaveAs)
        '.InitialFileName = CurrentProject.Path & "\" & contact_NO & ".doc"
        .InitialFileName = contact_NO & ".doc"
        If .Show Then strFileName = .SelectedItems(1) Else Exit Sub
    End With

    '文件名必须包括“.doc”的文件扩展名，如没有则自动加上
    If Not strFileName Like "*.doc" Then strFileName = strFileName & ".doc"
    '如果文件已存在，则删除已有文件
    If Dir(strFileName) <> "" Then Kill strFileName
    '打开模板文件
    Set objApp = CreateObject("Word.Application")
    objApp.Visible = True
    Set objDoc = objApp.Documents.Open(strTemplates, , False)

  '开始替换模板预置变量文本
   With objApp.Application.Selection
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        With .Find
             .Text = "{$合同编号}"
             .Replacement.Text = contact_NO
        End With
        .Find.Execute Replace:=wdReplaceAll

        With .Find
             .Text = "{$甲方}"
             .Replacement.Text = side_A
        End With
        .Find.Execute Replace:=wdReplaceAll

       With .Find
            .Text = "{$乙方}"
            .Replacement.Text = side_B
       End With
       .Find.Execute Replace:=wdReplaceAll
    End With

    '将写入数据的模板另存为文档文件
    objDoc.SaveAs strFileName
    objDoc.Saved = True            
    MsgBox "合同文本生成完毕！", vbYes + vbExclamation
Exit_cmdExportToWord_Click:
    If Not objDoc Is Nothing Then objApp.Visible = True
    Set objApp = Nothing
    Set objDoc = Nothing
    Set objTable = Nothing
    Exit Sub
Err_cmdExportToWord_Click:
    MsgBox Err.Description, vbCritical, "出错"
    Resume Exit_cmdExportToWord_Click
End Sub核心技术部分完毕，那么如何使用呢？
1、单击选定需要输出数据制作合同的行的任意单元格。比如我在此选定了第一行中的B2单元格，当然你可以选择该行的任意一单元格。


2、单击“生成”按钮，弹出合同模板选择对话框。在此，选择我们刚才制作好的合同模板。


3、打开应用该模板，然后随之弹出生成后的合同另存为的对话框。这里文件名会被自动保存为合同编号。


4、生成完毕。以下是效果


     以上是抛砖引玉的一个办法，仅需对代码中需要替换的部分进行更改，那么基本上可以做到复杂的输出。实际上技术难度没多大，仅仅是利用了Office里面的宏替换原理而已。经过改造，在实际的生产环境中，可以利用EXCEL从其它系统获取数据，然后再批量制作各种WORD文档。
<hr/>二次更新：
很多朋友提到了想批量输出生成Word的需求，在此，就对代码进行了一些修改，满足批量输出的需求。实际上实现的过程并不难，仅仅就是调整了代码块顺序，然后把获取变量和Word变量替换写进循环而已。
Private Sub cmd_makedoc_Click()
On Error GoTo Err_cmdExportToWord_Click
    Dim objApp As Object 'Word.Application
    Dim objDoc As Object 'Word.Document
    Dim strTemplates As String '模板文件路径名
    Dim strFileName As String '将数据导出到此文件
    Dim i As Integer
    Dim contact_NO As String
    Dim side_A As String
    Dim side_B As String
    Dim data_areas As Range
    Dim total_data As Integer
   
    Set data_areas = Application.InputBox(prompt:="请鼠标选择需要输出数据的区域", Title:="选择", Type:=8) '选取输出的数据区域
    i = data_areas.Row     '获取选取区域开始行所在行号
    j = data_areas.Rows.Count '  获取选取区域总行数
   
    With Application.FileDialog(msoFileDialogFilePicker) '选择模板文件
         .Filters.Add "word文件", "*.doc*", 1
         .AllowMultiSelect = False
         If .Show Then strTemplates = .SelectedItems(1) Else Exit Sub
    End With
    With Application.FileDialog(msoFileDialogFolderPicker)  '获取输出的文件存储路径
         If .Show = False Then Exit Sub
         path = .SelectedItems(1)
      End With
    Set objApp = CreateObject("Word.Application")
    objApp.Visible = false
   
    For k = i To i + j-1
      contact_NO = Cells(k, 1)
      side_A = Cells(k, 2)
      side_B = Cells(k, 3)
      
      Set objDoc = objApp.Documents.Open(strTemplates, , False)
      strFileName=contact_NO & ".doc"
     '文件名必须包括“.doc”的文件扩展名，如没有则自动加上
      If Not strFileName Like "*.doc" Then strFileName = strFileName & ".doc"
     '如果文件已存在，则删除已有文件
      If Dir(strFileName) <> "" Then Kill strFileName
     '打开模板文件

    '开始替换模板预置变量文本
     With objApp.Application.Selection
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
           With .Find
              .Text = "{$合同编号}"
              .Replacement.Text = contact_NO
           End With
        .Find.Execute Replace:=wdReplaceAll

           With .Find
              .Text = "{$甲方}"
              .Replacement.Text = side_A
           End With
        .Find.Execute Replace:=wdReplaceAll

           With .Find
              .Text = "{$乙方}"
              .Replacement.Text = side_B
           End With
       .Find.Execute Replace:=wdReplaceAll
    End With

    '将写入数据的模板另存为文档文件
    objDoc.SaveAs Path & "\" & strFileName
    objDoc.Saved = True
    objDoc.close
  next k      
     
    MsgBox "合同文本生成完毕！", vbYes + vbExclamation
Exit_cmdExportToWord_Click:
    Set objApp = Nothing
    Set objDoc = Nothing
    Set objTable = Nothing
    Exit Sub
Err_cmdExportToWord_Click:
    MsgBox Err.Description, vbCritical, "出错"
    Resume Exit_cmdExportToWord_Click
End Sub<hr/>第三次更新：
     本次更新，源于某个知友的建议，主要问题是解决Microsoft Word16.0 Object Library加载成功，但仍然无法完成替换的问题。各位如果遇到同样问题，可以参考该朋友的建议。以下是该知友专门给我发邮件的原文：

    首先十分感谢您在知乎上分享的这份文章，对解决我是实际问题非常有借鉴意义，之前总想着用Python解决问题，没想到VBA实际上更有效率。在应用VBA程序的时候遇到了一些问题，看了评论区之后发现许多朋友都遇到了同样的问题，那就是Word检测到了相应的替换目标，但是没有进行替换，并且查看加载项中是存在相应版本的Word object library。这个问题实际上在我这边是由于，虽然表面上 Word object library 已经被加载进来，但是实际上在VBA编辑器中“视图”选项卡中的“对象浏览器”中并没有“Word”库，如图。（起初没有Word）
解决方案是：重新在加载项中选择浏览找到“C:\Program Files\Microsoft Office\root\Office16”路径中找到“”MSWORD.OLB“重新加载，并且在对象浏览器中出现”Word“字样即可，如图：

    在此，非常感谢该位朋友的无私分享，我不知道这位朋的知乎号，所以没法在此专门@他或者专门给出名字了，抱歉！最后非常感谢各位朋友的支持！

我是郭大牛，此“大牛”非技术层面的大牛，是名大牛。关注我，分享更多的办公技巧，解放更多的时间划水。
<hr/><hr/>其它实用内容

郭大牛：分析报告自动化——Excel与Word数据互通
郭大牛：使用Excel自动批量发送邮件
郭大牛：如何快速的将EXCEL表格数据拆分成多个文件？
郭大牛：Excel向Word输出复杂图文
郭大牛：Excel中一个被严重忽视的大杀器功能
郭大牛：打造Excel与微信之间的交互渠道
郭大牛：VBA实现高级筛选
郭大牛：无边界办公——远程虚拟应用架构
郭大牛：无边界办公——WebDAV文件共享服务构建
郭大牛：无边界办公—内网穿透
郭大牛：Excel树形多级下拉菜单的应用
郭大牛：巧用数据验证制作模糊匹配的下拉列表
郭大牛：使用VBA自动生成文件目录制作文件管理系统
郭大牛：使用Excel来制作批命令完成重复工作
郭大牛：将数字金额转换为中文大写金额的方法
郭大牛：Excel多级下拉菜单制作
郭大牛：使用Access制作一个简单的收款管理及票据打印系统方法
郭大牛：如何使用最简单的办法实现中小企业的数据共享和办公协同？
郭大牛：一个基于Access构建的数据管理平台
郭大牛：基于EXCEL的条形码制作工具
郭大牛：基于EXCEL的财务数据查询工具
郭大牛：用友打印设置

徒手攀岩

你好大牛，我按照步骤没有生成模板，可以发我一个模板给我吗？工作中刚好很需要，谢谢！

庄洪涛

哪里遇到问题了呢？

梦想改变生活

合同编码为文件名的文档可以生成，到合同编号和甲方，乙方没有替换

我是仁交社

检查你的word中变量是否做了类似标注，VBA代码是否对应Word对应变量。这个批量替换实际上根本没难度

喜马拉雅星

你好，完全复制你的代码 严格按你的步骤操作，文档生成都没问题，但是替换功能全部无法实现 包括合同编号 甲方 乙方 能指点下原因吗？我的是wps

东土大唐高僧

好的  私信吧

吉生

你好，大佬，我用excel 2019按照程序走，到运行程序到生成文件那步，提示 出错 没有注册类是为什么呢

杨庆香

你看一下是不是没有加载microsoft word动态链接库。理论上来说是不需要加载的，以防万一office抽风，还是检查一下看看

春风得意满天飞

大佬大佬，请问只有side a 和side b ,是不是一次只能改两个，要是想改多一点，是不是类似的增加side c,d啊 ？