Create multiple charts from dynamic columns in a table

Question

I would like to create a macro that runs through a series of data in a table and is able to automatically create multiple formatted graphs from it.

Here is what I'm working with (below):

Sub MakeXYGraph()
    'https://stackoverflow.com/questions/62285791/dynamically-select-cells-and-input-in-chart
    Dim ws As Worksheet
    Set ws = Sheet1 'This is the codename of the sheet where the data is
    'For the test, deleting all the previous charts
    Dim vChartObject As ChartObject
    For Each vChartObject In ws.ChartObjects
        vChartObject.Delete
    Next vChartObject
    'rngData is the range where the data are. It is assumed that nothing else is on the sheet than what you displ
    Dim rngData As Range
    Set rngData = ws.UsedRange.Offset(1).Resize(ws.UsedRange.Rows.Count - 1)
    ' Get the number of series
    Dim iMaxSeries As Integer
    iMaxSeries = Application.WorksheetFunction.Max(rngData.Columns(1))
    ' Is the actual Series, but in the sheet it called Point
    Dim iPoint As Integer
    'Used for setting the ranges for the series data
    Dim lFirstRow As Long, lLastRow As Long, lFirstColumn As Long, lLastColumn As Long
    lFirstColumn = rngData(1).Column
    lLastColumn = rngData.Columns(rngData.Columns.Count).Column
    'Creating the Chart
    Dim cht As ChartObject
    Set cht = ws.ChartObjects.Add(Left:=250, Width:=500, Top:=50, Height:=300)
    With cht.Chart
        .ChartType = xlXYScatterLines
        'X axis name
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Vertical Displacement"
        'Y-axis name
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Vertical Coordinate"
        ' deleting the unwanted series (Excel tries to find out the data, but no need for it.)
        Do Until .SeriesCollection.Count = 0
            .SeriesCollection(1).Delete
        Loop
    End With
    For iPoint = 1 To iMaxSeries
        'Search for the first occurence of the point
        lFirstRow = rngData.Columns(1).Offset(-1).Find(what:=iPoint).Row
        'Search for the first occurence of the second point -1 is the last of this point
        If iPoint = iMaxSeries Then
            lLastRow = rngData.Rows(rngData.Rows.Count).Row - 1
        Else
            lLastRow = rngData.Columns(1).Find(what:=iPoint + 1).Row - 1
        End If
        'Add the series
        With cht.Chart.SeriesCollection.NewSeries
            .XValues = ws.Range(Cells(lFirstRow, lFirstColumn + 1), Cells(lLastRow, lLastColumn - 1))
            .Values = ws.Range(Cells(lFirstRow, lFirstColumn + 2), Cells(lLastRow, lLastColumn))
            .Name = "Point " & CStr(iPoint)
        End With
    Next iPoint
End Sub

Which plots the vertical coordinate vs. vertical displacement columns from this table:

To create this graph:

However, as you can see from the image with the table, I have multiple columns, and I would like to like to make graphs for several columns, all with the same format as the vertical coordinate vs. vertical displacement chart above, without interfering with the previous charts created. For example, the second graph that I would like to create is vertical coordinate vs. vertical stress. There is additional data on this worksheet, so one cannot just assume that the rest of the worksheet is blank.

One issue is that as you can see there are four different point numbers (1,2,3,4) and each point number is iterated 9 times. However, these numbers can change (for example there could be 8 Point numbers with three iterations each, and thus the data is dynamic and shouldn't just consider 4 Point No.'s with 9 iterations). And the table data will always be located starting from cell "C8". The current code deals with this.

The reason why the current code doesn't satisfy this is because it assumes that there is no other data on the worksheet where the table is (but there is). I want to be able to add more columns and create more charts (all of them plotted against vertical coordinate column) without affecting the other charts. Please if there is any way to modify the code so then I could create charts for several sets of data on the same worksheet then that would be much appreciated! I'm not sure what the best way to approach this is. Thank you.

https://drive.google.com/file/d/1cuW2eWYwrkNeJ-TmatiC4-PFodflNbSN/view?usp=sharing

Answer 1

Here's one approach:

Sub MakeXYGraph()

    Const PLOT_HEIGHT As Long = 200
    Const PLOT_WIDTH As Long = 300
    Dim ws As Worksheet
    Dim cht As ChartObject
    Dim rngData As Range, rngHeaders As Range
    Dim col As Long, posTop As Long, posLeft As Long
    Dim ptRanges As Object, pt, dataRows As Range, i As Long

    Set ws = Sheet1 'This is the codename of the sheet where the data is

    For i = ws.ChartObjects.Count To 1 Step -1
        ws.ChartObjects(i).Delete
    Next i

    Set rngData = ws.Range("C7").CurrentRegion
    Set rngHeaders = rngData.Rows(1) 'the header row
    Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1) 'just the data

    Set ptRanges = PointRanges(rngData.Columns(1))

    posTop = ws.Range("M2").Top
    posLeft = ws.Range("M2").Left

    For col = 3 To rngData.Columns.Count

        'add the chart
        Set cht = NewChart(ws, posLeft, PLOT_WIDTH, posTop, PLOT_HEIGHT, rngHeaders.Cells(col).Value)

        'loop over the keys of the dictionary containing the point numbers and corresponding ranges
        For Each pt In ptRanges
            Set dataRows = ptRanges(pt).EntireRow
            With cht.Chart.SeriesCollection.NewSeries
                .XValues = dataRows.Columns(rngData.Columns(col).Column)
                .Values = dataRows.Columns(rngData.Columns(2).Column)
                .Name = "Point " & pt
            End With
        Next pt

        posTop = posTop + PLOT_HEIGHT
    Next col
End Sub

'Scan the "point No" column and collect unique values and
'  corresponding ranges in a Scripting Dictionary object
'  assumes data is sorted by point no
Function PointRanges(pointsRange As Range) As Object
    Dim dict As Object, c As Range, p, rng As Range
    Set dict = CreateObject("scripting.dictionary")
    For Each c In pointsRange.Cells
        p = c.Value
        If Not dict.exists(p) Then
            dict.Add p, c 'add the start cell
        Else
            Set dict(p) = dict(p).Resize(dict(p).Count + 1) 'resize to add this cell
        End If
    Next c
    Set PointRanges = dict
End Function

'add a chart and do some initial configuration
Function NewChart(ws As Worksheet, L, W, T, H, yAxisName As String)
    Dim cht As ChartObject
    Set cht = ws.ChartObjects.Add(Left:=L, Width:=W, Top:=T, Height:=H)
    With cht.Chart
        .ChartType = xlXYScatterLines
        .Axes(xlCategory, xlPrimary).HasTitle = True 'X axis name
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = yAxisName
        .Axes(xlValue, xlPrimary).HasTitle = True 'Y-axis name
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Vertical Coordinate"
        .Axes(xlValue, xlPrimary).ReversePlotOrder = True
        Do While .SeriesCollection.Count > 0
            .SeriesCollection(1).Delete
        Loop
    End With
    Set NewChart = cht
End Function