使用Word表格数据快速创建图表

实例需求：Word的表格如下所示，标题行有合并单元格。

现在需要根据上述表格数据，在Word中创建如下柱图。如果数据在Excel之中，那么创建这个图并不复杂，但是Word中就没用那么简单了，虽然Word中可以插入图表，但是其数据源仍然是来自于Excel。

示例代码如下。

Sub CreateWordChart3()
    Dim oChart As Chart, oTable As Table
    Dim oSheet As Object ' Excel.Worksheet
    Const START_CELL = "AA1"
    Application.ScreenUpdating = False
    Set oTable = ActiveDocument.Tables(1)  ' modify as needed
    Set oChart = ActiveDocument.Shapes.AddChart.Chart
    Set oSheet = oChart.ChartData.Workbook.Worksheets(1)
    oTable.Range.Copy
    oSheet.Range(START_CELL).Select
    oSheet.Paste
    Call Create2DTable(oSheet, oSheet.Range(START_CELL))
    oChart.ChartData.Workbook.Close
    Application.ScreenUpdating = True
End Sub

【代码解析】

第4行代码指定辅助数据区域的起始单元格（下文中简称为锚点单元格）。

第5行代码禁止屏幕更新。

第6行代码获取活动文档中的第一个表格对象。

第7行代码在文档中添加一个Chart对象。

第8行代码获取Chart对象的Worksheet对象（即图表数据源所在工作表）。

第9行代码拷贝表格区域。

第10行代码选中锚点单元格。

第11行代码粘贴数据，实现将Word表格数据导入到Excel工作表中。

第12行代码调用Create2DTable过程转换数据。

第13行代码关闭Chart对象的源数据工作簿。

第14行代码恢复屏幕更新。

Sub Create2DTable(ByRef tmpSheet As Object, startCell As Object)
    Dim oDicCat As Object, oDicSt As Object, sKey, vKey
    Dim rCell As Object 
    Dim rC As Object 
    Dim i As Long, j As Long
    Set oDicCat = CreateObject("scripting.dictionary")
    Set oDicSt = CreateObject("scripting.dictionary")
    With startCell.CurrentRegion
        For Each rCell In .Rows(2).Cells
            If Len(rCell) > 0 Then
                oDicCat(rCell.Value) = ""
            End If
        Next
        For Each rCell In .Rows(1).Cells
            sKey = rCell
            If Len(sKey) > 0 Then
                If Not oDicSt.Exists(sKey) Then
                    Set oDicSt(sKey) = CreateObject("scripting.dictionary")
                    For Each vKey In oDicCat
                        oDicSt(sKey)(vKey) = ""
                    Next
                End If
                For Each rC In rCell.Offset(1).Resize(1, rCell.MergeArea.Count)
                    oDicSt(sKey)(rC.Value) = rC.Offset(1).Value
                Next
            End If
        Next
    End With
    Dim xlTab As Object 
    Set xlTab = tmpSheet.ListObjects("Table1")
    xlTab.DataBodyRange.Delete
    Dim RowCnt As Long, ColCnt As Long
    RowCnt = oDicSt.Count
    ColCnt = oDicCat.Count
    xlTab.Resize tmpSheet.Range("A1").Resize(RowCnt + 1, ColCnt + 1)
    With xlTab.Range
        .Cells(1, 1) = "REQ"
        For i = 1 To ColCnt
            .Cells(1, i + 1) = oDicCat.keys()(i - 1)
        Next
        For j = 1 To RowCnt
            sKey = oDicSt.keys()(j - 1)
            .Cells(j + 1, 1) = sKey
            For i = 1 To ColCnt
                .Cells(j + 1, i + 1) = oDicSt(sKey)(.Cells(1, i + 1).Text)
            Next
        Next
    End With
    startCell.CurrentRegion.Clear
End Sub

【代码解析】

第6~7行代码创建两个字典对象。

第8行代码获取辅助表格的单元格区域。

第9~13行代码循环遍历表格中第二行单元格，将排重的"类别"列表保存在字典对象oDicCat中。

第10行代码判断类别不为空，并且不等于行标题。

第14~27行代码循环遍历第一行单元格。

第15行代码获取单元格内容。

第16行代码判断单元格是否为空，即"评估状态"。

第17行代码判断"评估状态"是否存在于字典对象oDicRes中。

第18行代码以sKey为键，创建嵌套字典对象。

第19~20行代码为新建的字典对象增加"类别"，这样可以将数据表转换为规范的2D表格，即每个"评估状态"都包含3个类别，这样数据便于创建图表。

第23~25行代码读取第3行单元格数据，保存到对应的嵌套字典对象之中。

第30行代码获取工作表中的表格对象（ListObject）。

第31行代码清空表格数据区域。

第33~34行代码获取获取类别和"评估状态"的个数，这决定了数据表格的维度（行数和列数）。

第35行代码重设表格区域。

第37行代码写入数据。

第38~40行代码循环读取oDicCat中内容，写入表格标题行（类别）。

第41~47行代码写入表格数据。

第42~43行代码写入第一列"评估状态"。

第44~46行代码写入评估统计数据。

第49行代码清空辅助单元格区域。

---

运行示例代码，最终效果如下图所示。