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

创作时间:

作者:

@小白创作中心

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

引用

CSDN

https://blog.csdn.net/taller_2000/article/details/139106326

在Word中创建图表时，如果表格数据包含合并单元格，直接插入图表可能会遇到困难。本文将通过VBA代码示例，详细介绍如何将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