经验首页 前端设计 程序设计 Java相关 移动开发 数据库/运维 软件/图像 大数据/云计算 其他经验
当前位置:技术经验 » 程序设计 » VB.Net » 查看文章
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

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

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

原文链接:http://www.cnblogs.com/implementer/p/10338127.html

 友情链接: NPS  问卷模板