ExcelVBA实现一键生成word文字报告及批量操作[原创]

在很多工作中，经常需要写一些类似的报告，使用同一个模板，只是里面的数据不同，人工操作工程量大且容易出错，如果能用程序直接实现可以省去不少麻烦。

本文使用ExcelVBA实现，主要思路是使用word邮件合并功能，将word文字报告与Excel数据链接，不太了解邮件合并功能的戳：http://xinzhi.wenda.so.com/a/1517858371619706

本文内容适用于 快速填写word表格，快速填写一套word表格，根据excel表及一个模板文件快速生成文字报告，根据同一个excel表多个模板文件快速生成多个不同的文字报告。

本文使用office2007，最后一次使用office2016。

1，创建一个word文档作为模板，存为doc格式，命名为 模板。

2，创建一个Excel存放数据，将数据的名称输入至sheet2第一行，保存为xlsm格式，命名为 数据

以sheet1为源数据表（sheet1是之后输入数据的地方，只是为了纵向方便输入）

3，打开word采用邮件合并功能将刚刚创建的word模板与Excel数据文件链接，选择sheet2

插入合并域

4，打开Excel的vb编辑器（在设置中打开开发工具），插入模块，在模块中输入以下代码：

Sub merge()
    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Sheet1")
    Dim sh2 As Worksheet
    Set sh2 = Worksheets("Sheet2")
    '将sheet1的数据转换到sheet2中
    '-----------------单元格对应-------------------------
    sh2.Range("A2") = sh1.Range("B1")    '姓名
    sh2.Range("B2") = sh1.Range("B2")    '年龄
    '---------------------------------------------------
    ThisWorkbook.Save '保存
    Call outPut '调用邮件合并程序
End Sub

Private Sub outPut()    '邮件合并程序
      On Error GoTo errorhandle:
     Dim Wordapp As Word.Application
     Dim WordD As Word.Document
     Dim Modelpath As String
     Set Wordapp = New Word.Application
     Modelpath = ThisWorkbook.Path & "\模板.doc"    '模板地址
     ThisWorkbookPath = ThisWorkbook.Path & "\数据.xlsm"    '数据文件地址，与模板文件在同一路径下

      Set WordD = Wordapp.Documents.Open(Modelpath)     '打开模板
      Wordapp.Visible = True     '设置为可见

     '链接数据
     WordD.MailMerge.OpenDataSource Name:= _
        ThisWorkbookPath _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=ThisWorkbookPath;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engin" _
        , SQLStatement:="SELECT * FROM `Sheet2$`", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
     '生成文档
     With WordD.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
    End With

    WordD.Close '关闭文档
    Set WordD = Nothing
    Set Wordapp = Nothing
    Exit Sub
errorhandle:
    MsgBox ("程序出现运行错误！")
End Sub　　

5，点工具-引用，引用office等工程文件，因为是在excel中操作word，请务必引用Microsoft word

6，运行宏程序merge

做到这里，你会发现，完全可以用自己的字段去代替示例中的姓名、年龄，甚至可以用同样的方法加入更多的字段，不过一定要注意excel中的字段跟word中对应，在代码中的单元格对应部分也需要sheet1的内容跟sheet2中对应（虚线部分），当第一次执行成功之后，以后只需要修改sheet1中的内容，然后执行，就可以生成一篇文字报告了。

-----------------------------------------------------------批量操作------------------------------------------------------------------------------

当有多个word需要用到同一个数据表时，可以在模块中使用以下代码实现批量输入，程序自动保存至excel同目录下输出文件夹中（继续上面的例子，新建一个文件夹，命名为模板文件夹，分别复制刚才的模板.doc文件分别命名为模板1.doc、模板2.doc、模板3.doc，然后在数据.xlsm中执行宏程序，会发现程序会根据模板1、模板2、模板3使用数据.xlsm中的字段生成了新的对应的word文件）：

Sub merge()
    Dim sh1 As Worksheet
    Set sh1 = Worksheets("Sheet1")
    Dim sh2 As Worksheet
    Set sh2 = Worksheets("Sheet2")
    Dim Modelpath As String
    Dim ThisWorkbookPath As String
    Dim SaveFilePath, SaveFileName As String

    '将sheet1的数据转换到sheet2中
    '-----------------单元格对应-------------------------
    sh2.Range("A2") = sh1.Range("B1")    '姓名
    sh2.Range("B2") = sh1.Range("B2")    '年龄
    '----------------------------------------------------
    ThisWorkbook.Save '保存

    ThisWorkbookPath = ThisWorkbook.Path & "\数据.xlsm"
    SaveFilePath = ThisWorkbook.Path & "\输出文件夹\ "
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(SaveFilePath) = False Then
        MkDir SaveFilePath    '//创建文件夹
    End If
    '-----------------遍历模板-------------------------
    For i = 1 To 3  '模板个数，如果模板比较多的话，这里需要修改
        Modelpath = ThisWorkbook.Path & "\模板文件夹\模板" & i & ".doc"  '注意文件命名规律
        SaveFileName = "输出" & i   '输出的文件名
        Call outPut(Modelpath, ThisWorkbookPath, SaveFilePath, SaveFileName) '调用outPut方法
    Next i
    '--------------------------------------------------
End Sub

'Modelpath  模板路径
'ThisWorkbookPath   执行excel函数的路径
'SaveFilePath   文件保存路径
'SaveFileName   保存的文件名

Private Sub outPut(ByVal Modelpath As String, ByVal ThisWorkbookPath As String, ByVal SaveFilePath As String, ByVal SaveFileName As String)
    On Error GoTo errorhandle:
     Dim Wordapp As Word.Application
     Dim WordD As Word.Document
     Set Wordapp = New Word.Application

     Set WordD = Wordapp.Documents.Open(Modelpath)
     Wordapp.Visible = Visible

        WordD.MailMerge.OpenDataSource Name:= _
        ThisWorkbookPath _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=ThisWorkbookPath;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engin" _
        , SQLStatement:="SELECT * FROM `Sheet2$`", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
     '生成文档
        With WordD.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
    End With

    WordD.Close                         '关闭文档
    a = Wordapp.ActiveDocument.Name

    ' Wordapp.Windows("套用信函 1[兼容模式]").Activate
    Wordapp.ChangeFileOpenDirectory SaveFilePath
        Wordapp.ActiveDocument.SaveAs Filename:=SaveFileName, _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False '保存
    Wordapp.ActiveDocument.Close

    Set WordD = Nothing
    Wordapp.Quit
    Exit Sub
errorhandle:
    MsgBox ("程序出现运行错误！")
End Sub

输出结果：

如果文件名没有规律，可以逐个调用outPut方法，本文outPut方法可以结合更多操作方式来实现批量撰写报告~

-----------------------------------------------------------

转载请注明出处：https://www.cnblogs.com/implementer/