Forum Discussion
I am trying to make a separate charts for each row on the same sheet.
I have been looking for something like this forever, except my scenario is with XY plots and I want to plot in groups of n. For example, my time is in column B and my data goes through column CT. I want to have 3 consecutive columns per graph. Can something similar be done for this or is that too complicated for excel?
Thanks!
- BGrover42Jun 18, 2022Copper ContributorJonPeltier
Exactly right. But unfortunately beyond my limited macro skills. Glad to know it is doable. You would sure be my hero if you could help me out. Thanks again!- JonPeltierJun 18, 2022MVP
Here is the setup, with the data and the first chart. The first chart is selected so you can see the source data highlighted. I've hidden columns L:CQ so you can see the data extends to CT.
Here is the result. I've selected the second chart so you can see that the highlighted source data has moved to the right.
Here is the code. It does not assume a preset number of rows or columns. It uses the first series of the first chart to define the number of points, it uses the same X values as in the first chart for all charts. It uses as much data as it finds in the contiguous range that includes the first chart's data (so if it stops before or extends beyond CT, it still works). It does not assume three series but uses as many series as are in the first chart. it also does a trick with ActiveWorkbook.ChartDataPointTrack so that custom formatting isn't lost when you change the source data.
Sub DuplicateChart() If ActiveChart Is Nothing Then MsgBox "Select a chart and try again!", vbExclamation, "No Active Chart" GoTo ExitSub End If Dim cht As Chart Set cht = ActiveChart With cht Dim nSrs As Long nSrs = .SeriesCollection.Count Dim sFmla As String sFmla = .SeriesCollection(1).Formula Dim sArgs As String sArgs = Mid$(Left$(sFmla, Len(sFmla) - 1), InStr(sFmla, "(") + 1) Dim vArgs As Variant vArgs = Split(sArgs, ",") Dim sName As String, rName As Range sName = vArgs(LBound(vArgs)) On Error Resume Next Set rName = Range(sName) On Error GoTo 0 If Not rName Is Nothing Then Dim bNameIsRange As Boolean bNameIsRange = True End If Dim sYValues As String, rYValues As Range sYValues = vArgs(LBound(vArgs) + 2) Set rYValues = Range(sYValues) Dim dWidth As Double, dLeft As Double, dTop As Double dWidth = .Parent.Width dLeft = .Parent.Left dTop = .Parent.Top Dim nCharts As Long nCharts = (rYValues.CurrentRegion.Columns.Count - 1) / 3 End With ' do this or custom formatting of chart series will be lost Dim bChartDataPointTrack bChartDataPointTrack = ActiveWorkbook.ChartDataPointTrack ActiveWorkbook.ChartDataPointTrack = False Dim iChart As Long For iChart = 2 To nCharts Set cht = cht.Parent.Duplicate.Chart With cht With .Parent .Left = dLeft + (iChart - 1) * dWidth .Top = dTop End With .ChartTitle.Text = "Chart " & iChart Dim iSrs As Long For iSrs = 1 To nSrs Dim rNewYValues As Range Set rNewYValues = rYValues.Offset(, (iChart - 1) * 3 + iSrs - 1) .SeriesCollection(iSrs).Values = rNewYValues If bNameIsRange Then Dim rNewName As Range Set rNewName = rName.Offset(, (iChart - 1) * 3 + iSrs - 1) .SeriesCollection(iSrs).Name = "=" & rNewName.Address(, , , True) End If Next End With Next ActiveWorkbook.ChartDataPointTrack = bChartDataPointTrack ExitSub: End Sub
- BGrover42Jun 19, 2022Copper ContributorJonPeltier
This brings a tear to my eye. It's...so...beautiful.
Works perfectly and might be the greatest code I've ever seen. A million thanks.