如何根据excel数据自动生成word文档

Excel函数 2023-01-08

很多时候，您是否有过在WORD里面重复制作某种资料的工作。比如给定了合同模板，需要根据不同合同内容制作出不同的合同，但模板是一样的。一般情况下就是老老实实的一份一份的去填写（还不保证不会有错误）。那么有没有可以自动生完成的办法呢？答案是肯定有，不然我在这哔哔啥呢！接下来言归正传。在此上个大招，接下来就以合同为例：

1、制作合同模板文件，把合同变量部分用特殊变量替换。图示如下：

根据EXCEL数据自动生成WORD文档

2、在EXCEL里面添加合同主要内容数据，图示如下：

根据EXCEL数据自动生成WORD文档

3、在EXCEL里面添加一个Active X按钮控件，根据自身需要修改其属性。

根据EXCEL数据自动生成WORD文档

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
End Sub