如何根据EXCEL数据自动生成WORD文档? | 您所在的位置:网站首页 › qt导出word文档 › 如何根据EXCEL数据自动生成WORD文档? |
![]() 很多时候,您是否有过在WORD里面重复制作某种资料的工作。比如给定了合同模板,需要根据不同合同内容制作出不同的合同,但模板是一样的。一般情况下就是老老实实的一份一份的去填写(还不保证不会有错误)。那么有没有可以自动生完成的办法呢?答案是肯定有,不然我在这哔哔啥呢!接下来言归正传。在此上个大招,接下来就以合同为例: 1、制作合同模板文件,把合同变量部分用特殊变量替换。图示如下: 2、在EXCEL里面添加合同主要内容数据,图示如下: 3、在EXCEL里面添加一个Active X按钮控件,根据自身需要修改其属性。 4、在按钮控件下写如下代码,并将该EXCEL文件另存为XLSM: Private Sub cmd_makedoc_Click() On Error GoTo Err_cmdExportToWord_Click Dim objApp As Object 'Word.Application Dim objDoc As Object 'Word.Document Dim strTemplates As String '模板文件路径名 Dim strFileName As String '将数据导出到此文件 Dim i As Integer Dim contact_NO As String Dim side_A As String Dim side_B As String i = ActiveCell.Row contact_NO = Cells(i, 1) side_A = Cells(i, 2) side_B = Cells(i, 3) With Application.FileDialog(msoFileDialogFilePicker) .Filters.Add "word文件", "*.doc*", 1 .AllowMultiSelect = False If .Show Then strTemplates = .SelectedItems(1) Else Exit Sub End With '通过文件对话框生成另存为文件名 With Application.FileDialog(msoFileDialogSaveAs) '.InitialFileName = CurrentProject.Path & "" & contact_NO & ".doc" .InitialFileName = contact_NO & ".doc" If .Show Then strFileName = .SelectedItems(1) Else Exit Sub End With '文件名必须包括“.doc”的文件扩展名,如没有则自动加上 If Not strFileName Like "*.doc" Then strFileName = strFileName & ".doc" '如果文件已存在,则删除已有文件 If Dir(strFileName) "" Then Kill strFileName '打开模板文件 Set objApp = CreateObject("Word.Application") objApp.Visible = True Set objDoc = objApp.Documents.Open(strTemplates, , False) '开始替换模板预置变量文本 With objApp.Application.Selection .Find.ClearFormatting .Find.Replacement.ClearFormatting With .Find .Text = "{$合同编号}" .Replacement.Text = contact_NO End With .Find.Execute Replace:=wdReplaceAll With .Find .Text = "{$甲方}" .Replacement.Text = side_A End With .Find.Execute Replace:=wdReplaceAll With .Find .Text = "{$乙方}" .Replacement.Text = side_B End With .Find.Execute Replace:=wdReplaceAll End With '将写入数据的模板另存为文档文件 objDoc.SaveAs strFileName objDoc.Saved = True MsgBox "合同文本生成完毕!", vbYes + vbExclamation Exit_cmdExportToWord_Click: If Not objDoc Is Nothing Then objApp.Visible = True Set objApp = Nothing Set objDoc = Nothing Set objTable = Nothing Exit Sub Err_cmdExportToWord_Click: MsgBox Err.Description, vbCritical, "出错" Resume Exit_cmdExportToWord_Click |
CopyRight 2018-2019 实验室设备网 版权所有 |