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/