在很多工作中，经常需要写一些类似的报告，使用同一个模板，只是里面的数据不同，人工操作工程量大且容易出错，如果能用程序直接实现可以省去不少麻烦。
本文使用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
如果文件名没有规律，可以逐个调用outPut方法，输出结果：
本文outPut方法可以结合更多操作方式来实现批量撰写报告~
经验首页