使用Word Table的多个图表生成直方图

Question

我正在 Microsoft Word 中开发一个 VBA 宏，该宏应该根据 Word 文档中表格中的数据生成直方图（簇状列）。

如何使用下表修改宏以在同一类别内拥有多个分组图表，如下图所示？

我使用了以下代码来完成此任务：

Sub CreateWordChart()
    Dim oChart As Chart, oTable As Table
    Dim oSheet As Excel.Worksheet
    Dim RowCnt As Long, ColCnt As Long
    Application.ScreenUpdating = False
    ' get the first table in Doc
    Set oTable = ActiveDocument.Tables(1)  ' modify as needed
    Set oChart = ActiveDocument.Shapes.AddChart.Chart
    Set oSheet = oChart.ChartData.Workbook.Worksheets(1)
    ' get the size of Word table
    RowCnt = oTable.Rows.Count
    ColCnt = oTable.Columns.Count
    With oSheet.ListObjects("Table1")
        ' remove content
        .DataBodyRange.Delete
        ' resize Table1
        .Resize oSheet.Range("A1").Resize(RowCnt, ColCnt)
        ' copy Word table to Excel table
        oTable.Range.Copy
        .Range.Select
        .Parent.Paste
    End With
    oChart.PlotBy = xlRows
    oChart.ChartData.Workbook.Close
    Application.ScreenUpdating = True
End Sub

我得到了这个结果，与上一张图片不一样：

任何帮助将不胜感激。预先感谢！

Answer 1

• 如果你能在Word中按如下所示组织表格，那么代码就很简单了。

• 否则，您需要更多代码行来隐藏图表的数据源。

Option Explicit

Sub CreateWordChart2()
    Dim oChart As Chart, oTable As Table
    Dim oSheet As Excel.Worksheet, tmpSheet  As Excel.Worksheet
    Dim dataRng As Excel.Range
    Application.ScreenUpdating = False
    ' get the first table in Doc
    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("AA1").Select
    oSheet.Paste
    Call Create2DTab(oSheet)
    With oSheet.ListObjects("Table1")
        .DataBodyRange.Delete
        Set dataRng = oSheet.Range("AA1").CurrentRegion
        .Resize oSheet.Range("A1").Resize(dataRng.Rows.Count, dataRng.Columns.Count)
    End With
    dataRng.Copy oSheet.Range("A1")
    dataRng.Clear
    oChart.ChartData.Workbook.Close
    Application.ScreenUpdating = True
End Sub

Sub Create2DTab(ByRef tmpSheet As Worksheet)
    Dim oDicCat As Object, oDicSt As Object, sKey, vKey
    Dim rCell As Excel.Range, rC As Excel.Range
    Dim i As Long, j As Long
    Dim RowCnt As Long, ColCnt As Long, arrRes
    Set oDicCat = CreateObject("scripting.dictionary")
    Set oDicSt = CreateObject("scripting.dictionary")
    With tmpSheet.Range("AA1").CurrentRegion
        ' get the unique CatX list
        For Each rCell In .Rows(2).Cells
            If Len(rCell) > 0 Then
                oDicCat(rCell.Value) = ""
            End If
        Next
        ' loop through table
        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
                ' store values with nested Dict
                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
    ' get the size of Word table
    ColCnt = oDicSt.Count: RowCnt = oDicCat.Count
    ReDim arrRes(RowCnt, ColCnt)
    arrRes(0, 0) = "REQ"
    For i = 1 To RowCnt
        arrRes(i, 0) = oDicCat.keys()(i - 1)
    Next
    ' populate output array
    For j = 1 To ColCnt
        sKey = oDicSt.keys()(j - 1)
        arrRes(0, j) = sKey
        For i = 1 To RowCnt
            arrRes(i, j) = oDicSt(sKey)(arrRes(i, 0))
        Next
    Next
    ' write output to sheet
    With tmpSheet.Range("AA1")
        .CurrentRegion.Clear
        .Resize(UBound(arrRes, 2) + 1, UBound(arrRes) + 1).Value = Excel.Application.Transpose(arrRes)
    End With
End Sub