本博客链接： https://www.cnblogs.com/kenneth2012/p/16898599.html

VBA编程风格可以看到多种面向对象语言的影子，W3SCHOOL有专门的VBA基础编程教程。VBA是办公自动化一个很好的途径，提供了丰富的封装好的函数，有很好的灵活性、健壮性。

本教程内容主要为：用VBA编程的方式，提取excel内容，对word模板中特定位置进行替换。

实现了：定义输出文件名、输出至文件所在路径、生成批量word文档。
请注意，由于代码有部分bug没有解决，执行后需要手动打开一个word文档来激活进程，然后批量关闭。
参考的博客、文章附在最后，感谢前人的付出。

VBA编程环境。链接： https://pan.baidu.com/s/1iLXfy_85hLoxNxh1DYMRBg?pwd=gczy 提取码：gczy

安装后，可以在excel里开启VBA宏功能

WPS excel、word

从 环境配置 的网盘链接中下载压缩包。

Vba71.msi
Vba71_1033.MSI
Vba71_2052.msi
打开一个excel文件，点击开发工具。
可以看到，开发工具里有各种选项。我们先点击查看代码。
效果应该如图所示
打开VBA编辑器，添加项目引用
具体操作：选择“工具”—“引用”，然后打开加载文件选择框，选择“Microsoft Word16.0 Object Library”这个项目。这个引用是必须的，否则后期在执行变量替换时，VBA无法调用Word替换功能。
！请注意看代码注释！
Private Sub CommandButton1_Click()'这个位置按照自己控件修改，例如
    '我的控件名称为"CommandButton1"，自动生成了Private Sub CommandButton1_Click()
    '肯定会自动生成，如果打开之后发现是个空白框，请先添加按钮控件后，再查看代码
On Error GoTo Err_cmdExportToWord_Click
    Dim objApp As Object 'Word.Application
    Dim objDoc As Object 'Word.Document
    Dim objDocOrigin As Object 'Word.Document
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim strTemplates As String '模板文件路径名
    Dim strFileName As String '将数据导出到此文件
    Dim strData As String 'excel数据文件路径名
    Dim i As Integer '用来循环遍历，选中姓名的起始行号
    Dim j As Integer '用来循环遍历，选中区域的总行数
    Dim k As Integer '用来循环遍历，选择区域遍历的行号
    Dim Num As String '定义变量，序号
    Dim Name As String '定义变量，姓名
    Dim Fname As String '定义变量家属姓名
    Dim Pname As String '定义变量所在党组织全称
    Dim Rela As String '定义变量主要关系
    Dim data_areas As Range
    Dim total_data As Integer
    Dim result As String
    Dim n As Long '用来循环遍历
    Set data_areas = Application.InputBox(prompt:="请鼠标选择需要输出数据的区域", Title:="选择", Type:=8) '选取输出的数据区域
    i = data_areas.Row     '获取选取区域开始行所在行号
    j = data_areas.Rows.Count '  获取选取区域总行数
    over4Names = ""
    '如果希望不弹框选择文件和存放目录可以将下面三行前面的单引号去除，再将下面一段弹框选择文件的代码删除
    'strTemplates = "C:\Users\80668\Desktop\template.docx"
    'strData = "C:\Users\80668\data.xlsx"
    'Path = "C:\Users\80668\Desktop\报告20210113"
    '下面的一段代码是弹出3次框，分别选择模板文件doc，检测数据文件excel，报告存放目录
    With Application.FileDialog(msoFileDialogFilePicker) '选择word模板文件
         .Filters.Add "word文件", "*.doc*", 1
         .AllowMultiSelect = False
         If .Show Then strTemplates = .SelectedItems(1) Else Exit Sub
    End With
    With Application.FileDialog(msoFileDialogFilePicker) '选择excel文件
         .Filters.Add "word文件", "*.xls*", 1
         .AllowMultiSelect = False
         If .Show Then strData = .SelectedItems(1) Else Exit Sub
    End With
    With Application.FileDialog(msoFileDialogFolderPicker)  '获取输出的文件存储路径
         Path = ThisWorkbook.Path
    End With
   ' 忽略告警加快速度
   With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    Set objApp = CreateObject("Word.Application")
    objApp.Visible = False
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Open(strData)
    xlApp.Visible = False
    '下面去检测记录文件的第一个Sheet，可以通过名字取对应的sheet，例如xlBook.Worksheets("Sheet1")
    Set xlSheet = xlBook.Worksheets(1)
   ' 将检测表第4列的姓名数据全部取出来放到数组里面，遍历数组速度比遍历xlSheet速度要快很多
    nameArray = xlSheet.Range("D1:D" & xlSheet.Cells(Rows.Count, "D").End(xlUp).Row).Value
    ' 开始遍历选择的姓名和身份证
    For k = i To i + j - 1
      Num = Cells(k, 1)'序号'
      Name = Cells(k, 4) '姓名'
Pname = Cells(k, 7) '所在党组织的全称'
      Rela = Cells(k, 5)'主要关系'
      Fname = Cells(k, 6)'家属姓名'
      Set objDoc = objApp.Documents.Open(strTemplates, , False)
    '定义文件命名规则：序号_姓名+主要关系
    strFileName = Num & "_" & Name & Rela & ".docx" 
     '文件名必须包括“.docx”的文件扩展名，如没有则自动加上
      If Not strFileName Like "*.docx" Then strFileName = strFileName & ".docx"
     '如果文件已存在，则删除已有文件
      If Dir(strFileName) <> "" Then Kill strFileName
     '打开模板文件
    '开始替换模板预置变量文本
     With objApp.Application.Selection
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
           With .Find
              .Text = "{$Pname}"
              .Replacement.Text = Pname
           End With
        .Find.Execute Replace:=wdReplaceAll
            With .Find
              .Text = "{$Fname}"
              .Replacement.Text = Fname
           End With
        .Find.Execute Replace:=wdReplaceAll
           With .Find
              .Text = "{$Name}"
              .Replacement.Text = Name
           End With
        .Find.Execute Replace:=wdReplaceAll
           With .Find
             .Text = "{$Rela}"
             .Replacement.Text = Rela
           End With
        .Find.Execute Replace:=wdReplaceAll
    End With
    '将写入数据的模板另存为文档文件
    objDoc.SaveAs Path & "\" & strFileName
    objDoc.Saved = True
    objDoc.Close
Err_cmdExportToWord_Click:
    MsgBox Err.Description, vbCritical, "出错"
    Resume Exit_cmdExportToWord_Click
End Sub