ExcelVBA一键生成Word对账函-技术圈

Excel信息生成Word文档，是很多朋友经常遇到的场景，一条两条信息还好，但是如果有几百上千条信息，手动的去把excel内部的数据挪到Word里面，就很麻烦而且不现实了。这个时候，用VBA来支持，就能极大的提高效率。

今天就来讲一个典型的案例，本案例涉及知识点较多，例如：修改Word的页眉页脚内容（包含页码）、修改Word中的表格、新建文件夹等等，非常的经典。

可以说，把这个案例搞清楚了，Excel与Word数据交互的需求基本都不在话下了。

需求描述

我有这样两个文件：

Excel数据源

Word模板

我的具体需求：

取数据源表中的供应商，填至供应商名称栏位（尊敬的：后面）；
思路：找到关键字之后，光标挪动写入内容
取数据源表中的供应商的往来业务数据，插入至格式中的“1. 本公司与贵公司的往来账项”下的表格；表格后的内容自动下移。
思路：根据每个供应商的数据条数来新增不同行数。
保存文件时以供应商名称保存为文件名称，每个供应商独立一个文件
思路：保存文件的时候，文件名注意一下
帮我加上页脚的页数“第几页，共几页
思路：修改页眉页脚内容

具体代码和效果

具体代码如下：

    Public info()                                              '定义动态数组，存储每个供应商的具体信息    Public 供应商    Public doc    Public wd    Public PathG    Public i    Public docname    Public 贷方合计    Public 借方合计Sub 拆分excel至word()    Call 创建文件夹    贷方合计 = 0    借方合计 = 0    Set doc = CreateObject("word.application")                 '创建Word对象    arr = Sheet2.UsedRange                                     '把数据2中的数据赋值给数组arr，这里也可以写成arr=worksheets("数据2")    Set d = CreateObject("scripting.dictionary")               '创建字典，为了去重获取供应商名称    For i = 2 To UBound(arr)        d(arr(i, 13)) = ""                                     '去重写入字典    Next    供应商 = d.keys                                               '这里供应商就是所有供应商的数组                                           '显示进度条    On Error GoTo 1    For i = 0 To UBound(供应商)        '-------------------------------        Set wd = doc.Documents.Open(ThisWorkbook.Path & "\模板.docx")    '打开模板        'doc.Visible = True        For j = 1 To UBound(arr)            If arr(j, 13) = 供应商(i) Then                docname = arr(j, 12)                           '供应商编码，作为文档保存时候的命名                k = k + 1                ReDim Preserve info(1 To 6, 1 To k)                info(1, k) = arr(j, 1)                         '制单日期                info(2, k) = arr(j, 9)                         '科目名称                info(3, k) = arr(j, 3)                         '摘要                info(4, k) = arr(j, 4)                         '借方                info(5, k) = arr(j, 5)                         '贷方                info(6, k) = arr(j, 6)                         '会计期间                借方合计 = Val(info(4, k)) + 借方合计                贷方合计 = Val(info(5, k)) + 贷方合计            End If        Next j        Call 写入word        贷方合计 = 0        借方合计 = 0        k = 0    Next i1:     doc.Quit                                                '关闭Word程序窗口    MsgBox "完成！"End SubSub 写入word()                                               'endkey方法    '//写入供应商     doc.Visible = True    With doc.Selection.Find        .ClearFormatting        .MatchWholeWord = True        .MatchCase = False        t = .Execute(FindText:="尊敬的")                          '查找尊敬的三个字的位置    End With    doc.Selection.endkey unit:=5    doc.Selection.TypeText 供应商(i) & "："    '//写入往来账项    '--调整表格--    Set tbl = wd.Tables(1)    tbl.Select                                                 '选中需要填入数据的表格'不选中，后面无法插入行，InsertRowsBelow是selection的方法    ' If UBound(info, 2) > 1 Then doc.Selection.InsertRowsBelow UBound(info, 2) - 1   '根据总数据条数插入行,如果只有一条数据，不插入行    doc.Selection.InsertRowsBelow UBound(info, 2)              '根据总数据条数插入行,如果只有一条数据，不插入行    tbl.Style = "网格型"    '--写入数据--    For r = 1 To UBound(info, 2)        tbl.Cell(r + 1, 1).Range = info(1, r)        tbl.Cell(r + 1, 2).Range = info(2, r)        tbl.Cell(r + 1, 3).Range = info(3, r)        tbl.Cell(r + 1, 4).Range = info(4, r)        tbl.Cell(r + 1, 5).Range = info(5, r)        tbl.Cell(r + 1, 6).Range = info(6, r)    Next    tbl.Cell(r + 1, 4).Range = 借方合计    tbl.Cell(r + 1, 5).Range = 贷方合计    tbl.Cell(r + 1, 6).Range = 借方合计 - 贷方合计    Call 添加页眉页脚    doc.ActiveDocument.SaveAs Filename:=PathG & "\" & docname & ".docx"    '----保存到C盘    doc.ActiveDocument.Close 0End SubSub 创建文件夹()    'FSO方式    PathG = ThisWorkbook.Path & "\往来对账函"    Set fso = CreateObject("Scripting.FileSystemObject")    If fso.FolderExists(PathG) = True Then        fso.getfolder(PathG).Delete                            '//删除文件夹        MkDir PathG    Else        MkDir PathG                                            '//创建文件夹    End IfEnd SubSub 添加页眉页脚()    '//添加页眉    With wd.Sections(1).Headers(1)        Set Rng = .Range        Rng.Text = 供应商(i)        .Range.Fields.Update        .Range.ParagraphFormat.Alignment = 2    End With    '删除页眉横线    With wd.Styles("页眉").ParagraphFormat        .Borders(-3).LineStyle = 0    End With    '//添加页脚    With wd.Sections(1).Footers(1)        Set Rng = .Range        Rng.Text = "第 "        Rng.Collapse 0        wd.Fields.Add Rng, 33, "Page"        Set Rng = .Range        Rng.Collapse 0        Rng.Text = " 页  共 "        Rng.Collapse 0        wd.Fields.Add Rng, 26, "Pages"        Set Rng = .Range        Rng.Collapse 0        Rng.Text = " 页 " & 供应商(i)                              '页脚要求，第几页共几页+供应商名称        .Range.Fields.Update        .Range.ParagraphFormat.Alignment = 2    End WithEnd Sub