VBA应用

01 工作表

Office协同问题—将表格内容批量写入Word文档

一个关于Office协同的问题

Question1：

一个excel中有多个客户信息（例如姓名、身份证、购买物品数量），需要将每个客户的信息填到3份不同word文档中，如果有很多个客户，怎么样才能快速批量地为每位客户输出对应的3份word文档？

Answer1：

能明白你表述的大致意思，有些细节还是需要确认？

是一个客户的姓名、身份证、购买物品数量，输出一份Word文档；还是这三个字段需要对应写入到三个Word文档，姓名.docx、身份证.docx、购买物品数量.docx，还有三个字段只是写入到Word里就可以了？，还是有固定的填充位置？

Question2：

1、每份word文档都需要填入客户姓名、身份证、购买物品数量，需要输出3份不同的文档（购销合同、发货订单、财务报账单，需要填充的客户信息是一样的，但每份文档的整体内容跟用途不一样，所以是输出3份）；

2、客户信息的3个字段要填充到文档固定位置（已加横线区分位置）。

Answer2：

1、“2、客户信息的三个字段填充到文档的固定位置”，那么Word文档是需要有固化格式的，“姓名、身份证、购买数量”分别需要填入到哪个位置？。可以用三个“Word文档空出对应位置”作为范本，需要写入信息时，在范本中操作。
2、批量的对每个客户操作，这个用循环即可。
3、代码段和在本地直接运行想要得到的结果还是会有小的距离，在此基础上可自己略微调整，让它适合自己的工作需求。

最终VBA实现过程：

1、新建三个Word文档模版，名称分别为：“购销合同”、“发货订单”和“财务报账单”，模版文档中有需要写入的位置；
2、文档的保存路径是当前Excel工作簿文件所在的路径；
3、创建Word对象，在对客户名单的循环中，嵌套3个调用Word模版文档的循环，因为它们的写入方法是一样的；
4、查找判断“姓名、身份证、购买数量”三个字段的位置，在Word文档中的写入并填充；
5、另存Word文档，路径是当前路径、名称是序号+姓名+Word文档名；
6、不保存关闭作为范本的Word文档，以供下次循环使用，直到循环结束。

运行视频：

源码下载：

示例代码

复制成功!


Sub 客户信息批量写入模版文档()

    '自定义数据类型
    Dim File_Path As String, Save_Path As String
    File_Path = ThisWorkbook.Path '获取当前文件所在的路径
    Save_Path = File_Path & "\"   '文件的保存路径，即当前文件夹

    '获取员工数据
    Dim ws As Worksheet
    Dim Row_count As Long, i As Long
    Set ws = ThisWorkbook.Sheets("客户资料")                   '把数据原表赋给ws
    Row_count = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    '三个word文档模版的数组
    Dim word_array As Variant
    Dim j As Integer
    word_array = Array("购销合同", "发货订单", "财务报账单")

    Dim wdap As Object, wddoc As Object, wdtab As Object
    Dim r As Long, c As Long
    Dim Rng_text As String

    ' 禁用屏幕更新和警告
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set wdap = CreateObject("Word.Application")              ' 创建 Word 应用
    wdap.Visible = False                                     ' 后台运行
    For i = 2 To Row_count             '循环处理每一条客户信息
        For j = 0 To UBound(word_array)  '循环写入每一个word文档
            Set wddoc = wdap.documents.Open(Save_Path & word_array(j) & ".docx")    '打开word模版
            Set wdtab = wddoc.tables(1)                              '获取Word表格，word表格里只有1个表格

            '在表格中查找字段并填充数据
            For r = 1 To wdtab.Rows.Count         '遍历word文档中的所有单元格行
                For c = 1 To wdtab.Columns.Count  '遍历word文档中的所有单元格列
                    Rng_text = Trim(wdtab.cell(r, c).Range.Text) '获取单元格文本

                    If InStr(1, Rng_text, "客户姓名") > 0 Then          'Word里的当内容没有Excel里规范，会有回车\空格\换行等字符，这里用是否包含部分字段来判断
                        wdtab.cell(r, c + 1).Range.Text = ws.Cells(i, 2) '在下一个单元格写入对应的客户信息
                    End If
                    If InStr(1, Rng_text, "身份证号") > 0 Then
                        wdtab.cell(r, c + 1).Range.Text = ws.Cells(i, 3)
                    End If
                    If InStr(1, Rng_text, "购买数量") > 0 Then
                        wdtab.cell(r, c + 1).Range.Text = ws.Cells(i, 4)
                    End If
                Next c
            Next r

            wddoc.SaveAs Save_Path & ws.Cells(i, 1) & "、" & ws.Cells(i, 2).Value & "_" & word_array(j) & ".docx" '保存文档，命名为 “序号 + 姓名 + 文档名”
            wddoc.Close SaveChanges:=False       '关闭文档，不保存模块
        Next j
    Next i

    ' 恢复屏幕更新和警告
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "完成文档写入"  '过程结束！

End Sub