学习Excel技术，关注微信公众号：

excelperfect

我在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

代码中已经给出了详细的注释，有兴趣的朋友可以仔细体会。

运行代码

在运行代码前，要保证代码所在的工作簿与Word文档模板datafromexcel.docx在同一文件夹中。运行ExportDataToWord过程，在文件夹中会生成以列A中的姓名为名称的Word文档，如下图5所示。

图5

打开任一文档，结果都是填写好了的表格，如下图6所示。

图6

代码的图片版如下：