Generate a Histogram with multiple charts of a Word Table

Question

I am working on a VBA macro in Microsoft Word that is supposed to generate a histogram ( Clustered Column ) from data in a table within the document Word.

How can I modify the macro to have multiple grouped charts within the same category, as shown in the image below, using the following table?

I have used the following code to accomplish this task:

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

And I obtained this result, which is not the same as the previous picture:

Any help would be greatly appreciated. Thanks in advance!

Answer 1

• If you could organize the table in Word as shown below, then the code is simple.

• Otherwise, you need more code lines to covert data source for chart.

Option Explicit

Sub CreateWordChart3()
    Dim oChart As Chart, oTable As Table
    Dim oSheet As Excel.Worksheet
    Const START_CELL = "AA1"
    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(START_CELL).Select
    oSheet.Paste
    Call Create2DTable(oSheet, oSheet.Range(START_CELL))
    oChart.ChartData.Workbook.Close
    Application.ScreenUpdating = True
End Sub

Sub Create2DTable(ByRef tmpSheet As Worksheet, startCell As Excel.Range)
    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
    Set oDicCat = CreateObject("scripting.dictionary")
    Set oDicSt = CreateObject("scripting.dictionary")
    With startCell.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
    Dim xlTab As Excel.ListObject
    Set xlTab = tmpSheet.ListObjects("Table1")
    xlTab.DataBodyRange.Delete
    ' get the size of output table
    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
        ' populate output
        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