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

来源：cnblogs　　作者：ImplementDreams　　时间：2019/1/31 9:23:05　　对本文有异议

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

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

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

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

以sheet1为源数据表

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

插入合并域

4，打开Excel的vb编辑器，插入模块，在模块中输入以下代码：

 1 Sub merge()
 2     Dim sh1 As Worksheet
 3     Set sh1 = Worksheets("Sheet1")
 4     Dim sh2 As Worksheet
 5     Set sh2 = Worksheets("Sheet2")
 6     ‘将sheet1的数据转换到sheet2中
 7     sh2.Range("A2") = sh1.Range("B1")    '姓名
 8     sh2.Range("B2") = sh1.Range("B2")    '年龄
 9     ThisWorkbook.Save’保存
10     Call outPut’调用邮件合并程序
11 End Sub
12 
13 
14 
15 Private Sub outPut()    ’邮件合并程序
16 　　  On Error GoTo errorhandle:
17      Dim Wordapp As Word.Application
18      Dim WordD As Word.Document
19      Dim Modelpath As String
20      Set Wordapp = New Word.Application
21      Modelpath = ThisWorkbook.Path & "\模板.doc"    ’模板地址
22      ThisWorkbookPath = ThisWorkbook.Path & "\数据.xlsm"    ’数据文件地址，与模板文件在同一路径下
23             
24       Set WordD = Wordapp.Documents.Open(Modelpath)     '打开模板
25       Wordapp.Visible = True     '设置为可见
26 
27      '链接数据
28      WordD.MailMerge.OpenDataSource Name:= _
29         ThisWorkbookPath _
30         , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
31         AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
32         WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
33         Format:=wdOpenFormatAuto, Connection:= _
34         "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" _
35         , SQLStatement:="SELECT * FROM `Sheet2$`", SQLStatement1:="", SubType:= _
36         wdMergeSubTypeAccess
37      '生成文档
38      With WordD.MailMerge
39         .Destination = wdSendToNewDocument
40         .SuppressBlankLines = True
41         With .DataSource
42             .FirstRecord = wdDefaultFirstRecord
43             .LastRecord = wdDefaultLastRecord
44         End With
45         .Execute Pause:=False
46     End With
47 
48     WordD.Close '关闭文档
49     Set WordD = Nothing
50     Set Wordapp = Nothing
51     Exit Sub
52 　　 errorhandle:
53     MsgBox ("程序出现运行错误！")
54 End Sub

5，点工具-引用，引用office等工程文件

6，运行宏程序merge

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

当有多个word需要用到同一个数据表时，可以在模块中使用以下代码实现批量输入，程序自动保存至excel同目录下输出文件夹中：

 1 Sub merge()
 2     Dim sh1 As Worksheet
 3     Set sh1 = Worksheets("Sheet1")
 4     Dim sh2 As Worksheet
 5     Set sh2 = Worksheets("Sheet2")
 6     Dim Modelpath As String
 7     Dim ThisWorkbookPath As String
 8     Dim SaveFilePath, SaveFileName As String
 9 
10     ‘将sheet1的数据转换到sheet2中
11     sh2.Range("A2") = sh1.Range("B1")    '姓名
12     sh2.Range("B2") = sh1.Range("B2")    '年龄
13     ThisWorkbook.Save’保存
14 
15     ThisWorkbookPath = ThisWorkbook.Path & "\数据.xlsm"
16     SaveFilePath= ThisWorkbook.Path & "\输出文件夹\ "
17     Set FSO = CreateObject("Scripting.FileSystemObject")
18     If FSO.FolderExists(SaveFilePath) = False Then
19         MkDir SaveFilePath    '//创建文件夹
20     End If
21     for i=1 to 3    ‘模板个数
22      Modelpath = ThisWorkbook.Path & "\模板文件夹\模板" & i & “.doc”
23     SaveFileName =”输出” & i
24     Call outPut(Modelpath, ThisWorkbookPath, SaveFilePath,     SaveFileName)
25     next i
26 End Sub
27 
28 
29 Private Sub outPut(ByVal Modelpath As String, ByVal ThisWorkbookPath As String, ByVal SaveFilePath As String, ByVal SaveFileName As String)
30     On Error GoTo errorhandle:
31      Dim Wordapp As Word.Application
32      Dim WordD As Word.Document
33      Set Wordapp = New Word.Application
34      
35      Set WordD = Wordapp.Documents.Open(Modelpath)
36      Wordapp.Visible = Visible
37 
38         WordD.MailMerge.OpenDataSource Name:= _
39         ThisWorkbookPath _
40         , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
41         AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
42         WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
43         Format:=wdOpenFormatAuto, Connection:= _
44         "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" _
45         , SQLStatement:="SELECT * FROM `Sheet2$`", SQLStatement1:="", SubType:= _
46         wdMergeSubTypeAccess
47      '生成文档
48         With WordD.MailMerge
49         .Destination = wdSendToNewDocument
50         .SuppressBlankLines = True
51         With .DataSource
52             .FirstRecord = wdDefaultFirstRecord
53             .LastRecord = wdDefaultLastRecord
54         End With
55         .Execute Pause:=False
56     End With
57 
58     WordD.Close                         '关闭文档
59     a = Wordapp.ActiveDocument.Name
60     
61     ' Wordapp.Windows("套用信函 1[兼容模式]").Activate
62     Wordapp.ChangeFileOpenDirectory SaveFilePath
63         Wordapp.ActiveDocument.SaveAs Filename:=SaveFileName, _
64         FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
65         AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
66         EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
67         :=False, SaveAsAOCELetter:=False '保存
68     Wordapp.ActiveDocument.Close
69     
70     Set WordD = Nothing
71     Wordapp.Quit
72     Exit Sub
73     errorhandle:
74     MsgBox ("程序出现运行错误！")
75 End Sub