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

Since your data is the key it would be useful to share a sample worksheet with a "typical" dataset. — Tim Williams
– Tim Williams, Commented Jun 11, 2020 at 3:01
Hi @TimWilliams, thank you very much for reaching out. I think that is a good idea. Please see the updated question with the google drive link at the very bottom of the question. — Matcha22
– Matcha22, Commented Jun 11, 2020 at 13:03
@TimWilliams To explain the workbook a little, I have created the sample workbook with three examples of graphs that come from the corresponding table. The pattern for creating the graphs is the same, so I was thinking that the same code could be applied, no matter how many new columns were added. I hope this helps — Matcha22
– Matcha22, Commented Jun 11, 2020 at 13:16

Tim Williams · Accepted Answer · 2020-06-11 19:58:53Z

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

answered Jun 11, 2020 at 19:58

Tim Williams

169k8 gold badges104 silver badges143 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

Matcha22 Over a year ago

Hi @TimWilliams, first I just want to say thank you very much! In the separate spreadsheet that I gave you it works perfectly, so that's good. I'm just wondering what the line of code Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1) 'just the data does exactly, since when I use this code in my original workbook then VBA says that there is a Runtime Error 1004: 'Application Defined or Object Defined Error'. Do you know what this error could be referring to in this case? Thank you once again I really appreciate you help.

Tim Williams Over a year ago

The CurrentRegion line grabs the whole data table (headers and data, assuming the table contains no empty rows/columns, and there's nothing else "touching" it). The next couple of lines are assigning a range to the headers only, and then adjusting rngData to shift it one row down and shrink it by one row to exclude the headers. I can't say why that's a problem in your other worksheet, except to suggest to take a look at what CurrentRegion is returning.

Collectives™ on Stack Overflow

Create multiple charts from dynamic columns in a table

1 Answer 1

2 Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

2 Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related