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

本文使用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 Submerge()2 Dim sh1 AsWorksheet3 Set sh1 = Worksheets("Sheet1")4 Dim sh2 AsWorksheet5 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 CalloutPut’调用邮件合并程序11 End Sub

12

13

14

15 Private SuboutPut() ’邮件合并程序16 　　 On Error GoToerrorhandle:17 Dim Wordapp AsWord.Application18 Dim WordD AsWord.Document19 Dim Modelpath As String

20 Set Wordapp = NewWord.Application21 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 wdMergeSubTypeAccess37 '生成文档

38 WithWordD.MailMerge39 .Destination =wdSendToNewDocument40 .SuppressBlankLines = True

41 With.DataSource42 .FirstRecord =wdDefaultFirstRecord43 .LastRecord =wdDefaultLastRecord44 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 Submerge()2 Dim sh1 AsWorksheet3 Set sh1 = Worksheets("Sheet1")4 Dim sh2 AsWorksheet5 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 =”输出” &i24 CalloutPut(Modelpath, ThisWorkbookPath, SaveFilePath, SaveFileName)25 nexti26 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 GoToerrorhandle:31 Dim Wordapp AsWord.Application32 Dim WordD AsWord.Document33 Set Wordapp = NewWord.Application34

35 Set WordD =Wordapp.Documents.Open(Modelpath)36 Wordapp.Visible =Visible37

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 wdMergeSubTypeAccess47 '生成文档

48 WithWordD.MailMerge49 .Destination =wdSendToNewDocument50 .SuppressBlankLines = True

51 With.DataSource52 .FirstRecord =wdDefaultFirstRecord53 .LastRecord =wdDefaultLastRecord54 End With

55 .Execute Pause:=False

56 End With

57

58 WordD.Close '关闭文档

59 a =Wordapp.ActiveDocument.Name60

61 'Wordapp.Windows("套用信函 1[兼容模式]").Activate

62 Wordapp.ChangeFileOpenDirectory SaveFilePath63 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.Close69

70 Set WordD = Nothing

71 Wordapp.Quit72 Exit Sub

73 errorhandle:74 MsgBox ("程序出现运行错误！")75 End Sub

如果文件名没有规律，可以逐个调用outPut方法，输出结果：

本文outPut方法可以结合更多操作方式来实现批量撰写报告~