Hoping to get help with a Macro!

[PEM000]

Greetings All,

Regarding this thread: How to Create a Matrix Chart with Columns 'Grouped By'

I have a lot of these 'Matrix' charts to create for a project. I am hoping that someone can create a macro that will automate this.

Thanks very much!

Paul

Below is an attempt to get this done:

Option Explicit

' Version 5.0
'  - Creates an augmented "pillars with retreats" table on a new sheet
'  - Inserts a zero-value "Retreat" column before each real data column
'  - Builds a stacked bar chart so each data column is visually separated
'  - Leaves your original data unchanged

Sub CreatePillarsWithRetreats_V50()
    Dim wsSource As Worksheet, wsAug As Worksheet
    Dim rng As Range
    Dim dataArr As Variant
    Dim augData() As Variant

    Dim rowCount As Long, colCount As Long
    Dim i As Long, j As Long

    On Error GoTo ErrHandler

    '--- 1) Prompt user for data range ---
    Set wsSource = ActiveSheet
    Set rng = Application.InputBox( _
        Prompt:="Select the data range (top row = headers, first column = categories).", _
        Title:="Select Data Range", _
        Type:=8)
    If rng Is Nothing Then Exit Sub

    rowCount = rng.Rows.Count
    colCount = rng.Columns.Count

    If colCount < 2 Or rowCount < 2 Then
        MsgBox "Please select at least 2 columns (labels + data) and 2 rows (headers + data).", vbExclamation
        Exit Sub
    End If

    '--- 2) Load the user's range into a VBA array ---
    dataArr = rng.Value

    ' dataArr(1,1) : top-left cell (header of first column?)
    ' dataArr(1,2..colCount) : top row headers for data columns
    ' dataArr(2..rowCount,1) : category labels
    ' dataArr(2..rowCount,2..colCount) : numeric data

    '--- 3) Build the new "augmented" data array with retreats ---
    ' We'll create 1 "Retreat" col + 1 "Real" col for each data column
    ' That means for colCount - 1 data columns, we create (colCount - 1) * 2 columns
    ' Plus 1 column for the category labels
    ' => total columns in augmented table = 1 + 2*(colCount - 1)
    ' We'll have the same rowCount

    Dim totalAugCols As Long
    totalAugCols = 1 + 2 * (colCount - 1)  ' e.g., if user had 5 columns total, that's 1+2*4=9

    ReDim augData(1 To rowCount, 1 To totalAugCols)

    '--- Fill the augmented array ---
    '  The top-left column always copies the first column from the original data (categories).
    '  Then for each data column j=2..colCount:
    '     place 0 in the "retreat" column
    '     place the real data in the next column
    '
    '  We'll also place the appropriate headers in row 1
    '  For "Retreat" columns, we can label them "Retreat j-1" or something
    '  If you prefer them hidden, rename them or keep them blank.

    Dim augCol As Long

    For i = 1 To rowCount
        ' categories go in column 1
        augData(i, 1) = dataArr(i, 1)
    Next i

    For j = 2 To colCount
        ' the new pair of columns for original column j is:
        ' retreatCol = 2*(j-1)        => e.g. if j=2 => retreatCol=2
        ' realCol    = 2*(j-1) + 1    => e.g. if j=2 => realCol=3
        Dim retreatCol As Long, realCol As Long
        retreatCol = 2 * (j - 1)
        realCol = retreatCol + 1

        ' Fill row 1 (headers)
        If i = 1 Then
            augData(1, retreatCol) = "Retreat " & (j - 1)
            augData(1, realCol) = dataArr(1, j)
        End If

        For i = 2 To rowCount
            ' retreat columns = 0
            augData(i, retreatCol) = 0

            ' real data = dataArr(i, j)
            augData(i, realCol) = dataArr(i, j)
        Next i
    Next j

    '--- 4) Place the augmented data into a new or existing sheet named "AugmentedData" ---
    Dim sheetName As String
    sheetName = "AugmentedData"

    ' If a sheet with that name exists, we'll clear it; otherwise we'll add a new one.
    On Error Resume Next
    Application.DisplayAlerts = False
    Set wsAug = Worksheets(sheetName)
    On Error GoTo 0
    Application.DisplayAlerts = True

    If wsAug Is Nothing Then
        Set wsAug = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        wsAug.Name = sheetName
    Else
        wsAug.Cells.Clear
    End If

    ' Paste the augmented array starting at A1
    wsAug.Range("A1").Resize(rowCount, totalAugCols).Value = augData

    '--- 5) Create a stacked bar chart from the new table ---
    Dim chartObj As ChartObject
    Dim chartLeft As Double, chartTop As Double, chartW As Double, chartH As Double

    ' Decide where to place the chart (e.g. to the right of the table)
    chartLeft = wsAug.Columns(totalAugCols + 2).Left
    chartTop = wsAug.Rows(1).Top
    chartW = 500
    chartH = 350

    Set chartObj = wsAug.ChartObjects.Add( _
        Left:=chartLeft, Top:=chartTop, _
        Width:=chartW, Height:=chartH)

    With chartObj.chart
        .ChartType = xlBarStacked
        .HasTitle = True
        .ChartTitle.Text = "Pillars with Retreats (v5.0)"
        .Legend.Position = xlLegendPositionBottom

        ' We'll add a Series for each column in the augmented table (except col 1 which is categories).
        ' The columns we want to skip are the "Retreat" columns (2,4,6,...).
        ' The real data columns are 3,5,7,...
        ' We'll also remove the retreat columns from the Legend so they don't clutter it.

        Dim sCol As Long, sIdx As Long
        sIdx = 1

        For sCol = 2 To totalAugCols
            Dim newSrs As Series
            Set newSrs = .SeriesCollection.newSeries

            With newSrs
                .Values = wsAug.Range(wsAug.Cells(2, sCol), wsAug.Cells(rowCount, sCol))
                .XValues = wsAug.Range(wsAug.Cells(2, 1), wsAug.Cells(rowCount, 1))
                .Name = wsAug.Cells(1, sCol).Value  ' the header in row 1

                ' If this is a retreat column, we'll hide it from legend (and optionally color it transparent).
                If (sCol Mod 2 = 0) Then
                    ' Even columns => "Retreat"
                    .Format.Fill.Visible = msoFalse
                    .Format.Line.Visible = msoFalse
                    .HasDataLabels = False
                    .ApplyDataLabels
                    ' Hide from legend
                    .Name = ""  ' blank out the name to remove from legend in Excel 2019 or older
                    On Error Resume Next
                    .LegendEntry.Delete ' or it might fail in some versions
                    On Error GoTo 0

                Else
                    ' Odd columns => Real data
                    ' Assign color from a palette
                    Select Case sIdx
                        Case 1: .Format.Fill.ForeColor.RGB = RGB(0, 120, 200)   ' Blue
                        Case 2: .Format.Fill.ForeColor.RGB = RGB(0, 180, 80)    ' Green
                        Case 3: .Format.Fill.ForeColor.RGB = RGB(240, 200, 50)  ' Yellow
                        Case 4: .Format.Fill.ForeColor.RGB = RGB(0, 150, 200)   ' Teal
                        Case 5: .Format.Fill.ForeColor.RGB = RGB(128, 100, 162) ' Purple
                        Case 6: .Format.Fill.ForeColor.RGB = RGB(255, 102, 102) ' Light Red
                        Case 7: .Format.Fill.ForeColor.RGB = RGB(102, 205, 170) ' Aquamarine
                        Case 8: .Format.Fill.ForeColor.RGB = RGB(255, 160, 122) ' Salmon
                        Case Else
                            .Format.Fill.ForeColor.RGB = RGB(200, 50, 120)      ' Pink
                    End Select
                    sIdx = sIdx + 1
                End If
            End With
        Next sCol

        ' Category axis
        .Axes(xlCategory).HasTitle = False
        ' Remove value axis
        .Axes(xlValue).Delete
    End With

    MsgBox "Augmented table + stacked bar created on sheet '" & sheetName & "'.", vbInformation
    Exit Sub

ErrHandler:
    MsgBox "Error: " & Err.Description & vbCrLf & "Line: " & Erl, vbCritical, "Error " & Err.Number
End Sub