VBA专题06-6：利用Excel中的数据自动化构建Word文档—Excel与Word整合示例3

' 从Excel获取数据填充Word模板
' 来源于Professional ExcelDevelopment(2nd Edition)
Sub WordGenerateDivisionSummaries()
   Dim wrdApp As Word.Application
   Dim wrdDoc As Word.Document
   Dim wrdrngBM As Word.Range
   Dim piDiv As Excel.PivotItem
   Dim rngBookmark As Excel.Range
   Dim sPath As String
   Dim sBookmarkName As String
   On Error GoTo ErrorHandler
    '启动Word
   Set wrdApp = CreateObject("Word.Application")
    '获取路径
   sPath = ThisWorkbook.Path & "\"
    '基于模板创建新文档
   Set wrdDoc = wrdApp.Documents.Add(Template:=sPath &"SalaryReport.dotx")
    '遍历数据透视表中的每个部门
   For Each piDiv In wksData.PivotTables(1).PivotFields("Division").PivotItems
        '填充部门名称单元格
       wksData.Range("ptrDivName") = piDiv.Value
        '更新该部门相应的数据
       wksData.Calculate
        '使用工作表数据填充模板中的书签
       For Each rngBookmark In wksData.Range("rngBookmarks").Rows
            '获取书签名
            sBookmarkName =rngBookmark.Cells(1, 1).Value
            '获取书签相关的Word范围区域
            Set wrdrngBM =wrdDoc.Bookmarks(sBookmarkName).Range
            '设置该区域的文本(这将删除该书签)
            wrdrngBM.Text =rngBookmark.Cells(1, 2).Text
            '重新创建书签以便下次循环
            wrdDoc.Bookmarks.Add sBookmarkName,wrdrngBM
       Next rngBookmark
        '更新与这些书签链接的字段
       wrdDoc.Fields.Update
        '保存填充好的文档
       wrdDoc.SaveAs sPath & "SalaryResults - " & piDiv.Value& ".doc"
   Next piDiv
   MsgBox "部门薪酬汇总报表已成功生成."
ErrorExit:
   On Error Resume Next
    '关闭Word文档
   wrdDoc.Close
   Set wrdDoc = Nothing
    '退出Word程序
   wrdApp.Quit False
   Set wrdApp = Nothing
   Exit Sub
ErrorHandler:
    '显示错误号和错误描述
    '在标题栏备注程序
   MsgBox "错误 " &Err.Number & vbLf & Err.Description, _
          vbCritical, "程序:WordGenerateDivisionSummaries"
   Resume ErrorExit
End Sub