excel利用vba批量生成word报告

参考文章，下面的代码全部是基于参考网址修改得到的，非常感谢原作者

背景

朋友每天在人工出报告上需要耗费很多时间，有3个文件，一个是需要出报告用户的基本信息excel文件user.xlst，另外一个是用户的检测记录excel文件data.xlsx，生成word报告模板template.docx

说明：下面很多内容是模拟的，但是和原报告基本相似，脚本文件理论上是可以运行的，我当前电脑是mac无法运行

准备报告模板文件template.docx

准备检测记录文件data.xlsx

一个用户会有多条检测记录，取第一条检测记录的编号做为报告的编号，上面的数据按照固定格式放在第一个Sheet下面

准备用户名单user.xlsx

性别是根据身份证号码的第17位判断的，偶数为女，奇数为男

制作宏文件"报告工具.xlsm"

模板制作记录

• 参考顶部的链接中创建一个按钮，名字修改为：cmd_makedoc，标题修改为：生成报告
• 修改vba代码， 开发工具–》 查看代码，如果开发工具没有显示出来，请参考来调整， 程序上面的变量定义建议写出来加快程序速度
• 代码如下

Private Sub cmd_makedoc_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 m As Integer '用来循环遍历
    Dim h As Integer '用来循环遍历
    Dim l As Integer '用来循环遍历
    Dim userName As String '定义变量，姓名
    Dim sex As String '定义变量性别
    Dim idno As String '定义变量身份证号码
    Dim sampleNo As String '定义变量编号
    Dim takeTime(4) As String '定义变量数组，送样时间，目前暂定为4，根据实际情况修改
    Dim detectTime(4) As String  '定义变量数组，检测时间
    Dim checker(4) As String '定义变量数组, 检测人员
    Dim data_areas As Range
    Dim total_data As Integer
    Dim current As Integer
    Dim over4Names As String '定义一个字符串记录下超过4条记录的用户姓名，在最后输出提示
    Dim result As String
    Dim n As Long '用来循环遍历
    Dim nameArray As Variant '定义一个可变数组将检测表姓名列的数据存下来，加快遍历速度
   
    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)  '获取输出的文件存储路径
         If .Show = False Then Exit Sub
         Path = .SelectedItems(1)
    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)
    
   ' 将检测表第2列的姓名数据全部取出来放到数组里面，遍历数组速度比遍历xlSheet速度要快很多
    nameArray = xlSheet.Range("B1:B" & xlSheet.Cells(Rows.Count, "B").End(xlUp).Row).Value
    
    ' 开始遍历选择的姓名和身份证
    For k = i To i + j - 1
      userName = Cells(k, 1) '取第一列的姓名
      idno = Cells(k, 2) '取第二列的身份证
      sampleNo = "" '清空编号
      sex = "男" '性别默认为男
      current = 0 '初始化为0，用于检测时间数组的数据填充
      '清空送样时间、检测时间、检测人员数组，防止数据错乱
      For h = 1 To 4
        takeTime(h) = ""
        detectTime(h) = ""
        checker(h) = ""
      Next
      '如果身份证号码第17位是偶数将性别修改为女性
      If Val(Mid(idno, 17, 1)) Mod 2 = 0 Then sex = "女"
      
      '遍历检测记录姓名数组，根据用户姓名匹配所有的检测记录, UBound(nameArray, 1)取姓名数组的最大行号
      '第一版程序遍历excel比较姓名是否一致：For n = 3 To xlSheet.UsedRange.Rows.Count  If xlSheet.Cells(n, 2) = patientName Then
      '第一版程序直接遍历excel的速度非常慢，2分钟才出一份报告，改为数组遍历以后2分钟可以出50份报告了
      For n = 2 To UBound(nameArray, 1)
        If nameArray(n, 1) = userName Then
          If Len(sampleNo) = 0 Then sampleNo = xlSheet.Cells(n, 1)
          current = current + 1
          If current < 5 Then
            takeTime(current) = xlSheet.Cells(n, 4)
            detectTime(current) = xlSheet.Cells(n, 5)
            checker(current) = xlSheet.Cells(n, 12)
          ElseIf current = 5 Then
            over4Names = over4Names & "," & userName
          End If
        End If
      Next
      
      Set objDoc = objApp.Documents.Open(strTemplates, , False)
      strFileName = userName & ".docx"
     '文件名必须包括“.doc”的文件扩展名，如没有则自动加上
      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 = "{$姓名}"
              .Replacement.Text = userName
           End With
        .Find.Execute Replace:=wdReplaceAll
 
            With .Find
              .Text = "{$性别}"
              .Replacement.Text = sex
           End With
        .Find.Execute Replace:=wdReplaceAll
        
           With .Find
              .Text = "{$身份证}"
              .Replacement.Text = idno
           End With
        .Find.Execute Replace:=wdReplaceAll
        
           With .Find
             .Text = "{$编号}"
             .Replacement.Text = sampleNo
           End With
        .Find.Execute Replace:=wdReplaceAll
        
        
           With .Find
             .Text = "{$年}"
             .Replacement.Text = Year(Now)
           End With
        .Find.Execute Replace:=wdReplaceAll
        
           With .Find
             .Text = "{$月}"
             .Replacement.Text = Month(Now)
           End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{$日}"
             .Replacement.Text = Day(Now)
           End With
        .Find.Execute Replace:=wdReplaceAll
        ' 循环次数根据实际情况修改，demo是4条记录所以为4
        For m = 1 To 4
           With .Find
             .Text = "{$送样时间" & m & "}"
             .Replacement.Text = takeTime(m)
            End With
          .Find.Execute Replace:=wdReplaceAll
        
           With .Find
             .Text = "{$检测时间" & m & "}"
             .Replacement.Text = detectTime(m)
            End With
          .Find.Execute Replace:=wdReplaceAll
          
          With .Find
             .Text = "{$检测人" & m & "}"
             .Replacement.Text = checker(m)
            End With
          .Find.Execute Replace:=wdReplaceAll

        Next
    End With
 
    '将写入数据的模板另存为文档文件
    objDoc.SaveAs Path & "\" & strFileName
    objDoc.Saved = True
    objDoc.Close
    
  Next
  
   '将先前的忽略告警恢复为true
   With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    result = "报告生成完毕！"
    If Len(over4Names) > 0 Then result = result & "注意下面人员超过了4次检测记录：" & over4Names
     
    MsgBox result, vbYes + vbExclamation
Exit_cmdExportToWord_Click:
    Set objApp = Nothing
    Set objDoc = Nothing
    Set objTable = Nothing
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Exit Sub
Err_cmdExportToWord_Click:
    MsgBox Err.Description, vbCritical, "出错"
    Resume Exit_cmdExportToWord_Click
End Sub

报告生成操作步骤

1. 先将需要出报告的用户信息粘贴到"报告工具.xlsm"
2. 点击生成报告按钮，注意如果有提示需要启用安全内容，否则无法运行VBA
3. 弹出一个框，选择需要生成报告用户的区域，然后点击确认
4. 弹出文件选择框，选中模板文件template.docx
5. 弹出文件选择框，选中检测记录文件data.xlsx
6. 弹出文件夹选择框，选中需要报告存放的目录，例如目录"报告20210103"
7. 等待程序运行，如果有word提示的弹框"xxx文件被锁定，无法编辑"，点击"只打开副本"，目前每生成一个word需要点击一次
8. 如果提示word的模板文件被锁定无法编辑的情况下，建议将原模板doc文件复制出来，使用新复制的doc模板文件来生成报告就不会有弹框的情况，不用每生成一个word点击一次

生成报告结果

报告20210113/张三.docx

报告20210113/李四.docx

存在的问题和待改进

• 每次运行程序以后会弹出一个小框，需要点击’打开只读副本’以后才会继续生成word文件, 这种情况需要复制一个新的模板word文件，使用新的文件生成报告才不会有提示了
• vba代码格式比较乱
• 检测记录的模板中行数是固定的，demo中默认是4条，无法做到自动根据实际检测数伸缩

参考文章

官网打开word
先保存到数组里面再遍历优化匹配速度