调用excel数据自动生成word文档

应用场景：相信很多时候，您是否有过和博主一样在WORD里面重复制作某种资料的工作。比如给定了一份模板，需要根据不同内容制作出不同的word，但模板是一样的。一般情况下就是老老实实的一份一份的去填写（但人力填写难保证不出错，精力有限）。那么有没有可以自动生完成word的办法呢？答案是肯定有，接下来就以输出一份计算书为例：

工具

本次以博主电脑在用的excel365为例，用VBA调用word控件替换word中。

步骤

1. 首先要有word模板吧；其中需要替换的数据采用特殊变量替换。图示如下：

PS：图中均用{%xxx}的形式表示需要替换的特殊变量。

2. excel里面的添加需要输出的内容数据。图示如下：

PS：图中博主需要输出的数据为标黄色的那列。

3. EXCEL里面打开开发者模式（毕竟要写点代码）。

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

5. 打开EXCEL里的VBA编辑器；选择“工具”—“引用”，然后打开加载文件选择框，选择“Microsoft Word16.0 Object Library”这个项目，如下图：

PS：Word项目“Microsoft Word16.0 Object Library”这个必须引用起来，否则后期在执行变量替换时，VBA无法调用Word替换功能。

6. 在刚才加的按钮控件下写如下代码，并将该EXCEL文件另存为XLSM：

Private Sub CommandButton1_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_dew As String
    Dim contact_area As String
    Dim contact_flood As String
    Dim side_1 As String
    Dim side_2 As String
    Dim side_3 As String
    Dim side_4 As String
    Dim side_5 As String
    Dim side_6 As String
    Dim side_7 As String
    Dim side_8 As String
    Dim side_9 As String
    Dim side_11 As String
    Dim side_12 As String
    Dim side_13 As String
    Dim side_14 As String

    i = ActiveCell.Column
    contact_dew = Cells(4, i)
    contact_area = Cells(5, i)
    contact_flood = Cells(6, i)
    side_1 = Cells(7, i)
    side_2 = Cells(8, i)
    side_3 = Cells(9, i)
    side_4 = Cells(10, i)
    side_5 = Cells(11, i)
    side_6 = Cells(12, i)
    side_7 = Cells(13, i)
    side_8 = Cells(15, i)
    side_9 = Cells(16, i)
    side_10 = Cells(17, i)
    side_11 = Cells(18, i)
    side_12 = Cells(19, i)
    side_13 = Cells(23, i)
    side_14 = Cells(24, i)
 
    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 = "{%dew}"
             .Replacement.Text = contact_dew
        End With
        .Find.Execute Replace:=wdReplaceAll
 
        With .Find
             .Text = "{%area}"
             .Replacement.Text = contact_area
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%fl}"
             .Replacement.Text = contact_flood
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%qcda}"
             .Replacement.Text = side_1
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%qcda1}"
             .Replacement.Text = side_2
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%vf}"
             .Replacement.Text = side_3
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%dp}"
             .Replacement.Text = side_4
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%op}"
             .Replacement.Text = side_5
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%cpd}"
             .Replacement.Text = side_6
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%spd}"
             .Replacement.Text = side_7
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%mpl}"
             .Replacement.Text = side_8
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%mpf}"
             .Replacement.Text = side_9
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%twl}"
             .Replacement.Text = side_10
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%twf}"
             .Replacement.Text = side_11
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%twd}"
             .Replacement.Text = side_12
        End With
        .Find.Execute Replace:=wdReplaceAll
        
        With .Find
             .Text = "{%mplo}"
             .Replacement.Text = side_13
        End With
        .Find.Execute Replace:=wdReplaceAll
 
       With .Find
            .Text = "{%twpl}"
            .Replacement.Text = side_14
       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