Excel应用实践20：使用Excel中的数据自动填写Word表格

fanjy

发布于 2019-08-30 13:14:59

7.5K30

代码可运行

文章被收录于专栏：完美Excel完美Excel

运行总次数：0

代码可运行

我在Excel工作表中存放着数据，如下图1所示。

图1

我想将这些数据逐行自动输入到Word文档的表格中并分别自动保存，Word文档表格如下图2所示，文档名为“datafromexcel.docx”。

图2

解决思路

首先，将需要自动填写的datafromexcel.docx文档作为模板，并对每个要填写的位置放置书签。例如，将光标移至上图2所示表格中姓名后的空格，单击功能区选项卡“插入——书签”，在弹出的“书签”对话框中输入书签名“姓名”，如下图3所示。

图3

同样，在表的其它空格中插入相应的书签，结果如下图4所示。

图4

在Excel工作表中，将相应数据所在的单元格命名，名称与要填写的上图4中表的书签名相同。这就需要我们先命名单元格，待将相应的数据输出到Word表中后，再删除这些名称。然后，移至下一行，再进行单元格命名，并将相应的数据输出到Word表中，再删除这些名称。如此反复，直至工作表每行数据均创建了Word文档。

编写代码

按照上述思路，在存放数据的Excel工作簿中编写代码：

Sub ExportDataToWord()
    '变量声明
    Dim objWord As Object,docWord As Object
    Dim wb As Workbook
    Dim xlName As Name
    Dim Path As String
    Dim lLastRow As Long
    Dim i As Long
    '下面两个变量可修改为实际工作簿和路径
    '设置数据所在工作簿
    Set wb = ActiveWorkbook
    '要输入数据的Word模板
    Path = wb.Path & "\datafromexcel.docx"
    '错误处理
    On Error GoTo ErrorHandler
    '工作簿工作表中最后数据行行号
    lLastRow =wb.Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    '遍历工作表数据行
    '从中取出数据填充Word文档
    For i = 2 To lLastRow
        '命名名称
        With wb.Worksheets("Sheet1")
           .Range("A" & i).Name = Range("A1").Value
           .Range("B" & i).Name = Range("B1").Value
           .Range("C" & i).Name = Range("C1").Value
           .Range("D" & i).Name = Range("D1").Value
        End With
        '创建新的Word实例
        Set objWord = CreateObject("Word.Application")
        '错误处理
        On Error GoTo ErrorHandler
        '打开Word文档
        Set docWord = objWord.Documents.Add(Path)
        '遍历当前工作簿中的名称
        For Each xlName In wb.Names
            '如果在Word文档中存在与名称相同的书签
            If docWord.Bookmarks.Exists(xlName.Name) Then
                '将工作表名称的值放入书签所在位置
               docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
            End If
        Next xlName
        With objWord
            '激活并显示Word文档
            .Visible = True
           .ActiveWindow.WindowState = 0
            .Activate
            '以列A中相应单元格中的数据命名并保存Word文档
           .ActiveDocument.SaveAs wb.Path & "\" & Range("A" & i).Value & ".docx"
            '退出Word
            .Application.Quit
        End With
        '释放对象
        Set objWord = Nothing
        '删除名称
       Names(Range("A1").Value).Delete
       Names(Range("B1").Value).Delete
       Names(Range("C1").Value).Delete
       Names(Range("D1").Value).Delete
    Next i
     '释放Word对象并退出过程
ErrorExit:
    Set objWord = Nothing
    Exit Sub
    '错误处理
ErrorHandler:
    If Err Then
        MsgBox "错误号: " & Err.Number &"; 出问题了."
        If Not objWord Is Nothing Then
            objWord.QuitFalse
        End If
        Resume ErrorExit
    End If
End Sub