Loop to create charts automatically

[GeeWhiz7]

Hi folks,
I am not very versant with chart objects and keep getting stuck with the following problem. Thanks for your help!

I have put a simple version of a minisheet below with data. I could not figure out how to capture the charts in the minisheet so an image of the "desired result" is also uploaded.

What I am trying to do.

• I want to automatically create scatter charts for every second row of data where the the X data is always the A1 (Date) column, but the Y data is every nth+2 column (Tons).
• Add chart title that equals the header value for that column
• Put the chart below the previous chart offset by some increment to the top so they are evenly spaced
• Make the chart object name equal also to the header name so that by the end of the loop each chart object has its own name so I can reference them elsewhere.

I tried to loop a macro recording by copying a "template" chart then assigning the source data, but can't quite get things to work as I have not had any experience with chart objects and the syntax.

What I was thinking...but does not work

Sub ChartMaker()

Dim rng As Range
Dim rowNum As Long
Dim topInc As Long


Sheets("Charts").Activate

rowNum = 2
topInc = 300 

For Each rng In Range("B2:I2").Columns
    
    Dim chartObj As ChartObject
    Dim refChart As Chart
      
    Set chartObj = ActiveSheet.ChartObjects.Add(Top:=10 + topInc, Left:=325, Width:=600, Height:=300) 'place the next chart incrementally below the previous chart until all charts are made..
    Set refChart = chartObj.Chart
    refChart.ChartType = xlXYScatter
    refChart.SetSourceData Source:=Range(Cells(2, rowNum), Cells(30, 2)) 'Getting lost here, I dont quite know how to set X (date) and Y data separately
    
    ActiveChart.SetElement (msoElementChartTitleAboveChart)
        ActiveChart.ChartTitle.Text = Cell(2, rowNum) 'Trying to add chart title equal to the header like A Tons or B Tons
    
    With Chart
        .Parent.Name = rowNum 'would like chart object name to be equal to the header like A_Tons or B_Tons, etc

    End If
    
rowNum = rowNum + 2 'idea is to make a chart for every second row.

Next rng

End Sub

Book2.xlsx
	A	B	C	D	E	F	G	H	I
1	Date	A Tons	A Over	B Tons	B Over	C Tons	C Over	D Tons	D Over
2	6/3/2022	13	1	59	47	27	15	38	26
3	6/2/2022	13	1	14	2	15	3	42	30
4	6/1/2022	42	30	17	5	29	17	26	14
5	5/31/2022	63	51	33	21	41	29	67	55
6	5/30/2022	50	38	52	40	23	11	13	1
7	5/29/2022	41	29	46	34	38	26	74	62
8	5/28/2022	80	68	14	2	70	58	67	55
9	5/27/2022	15	3	13	1	50	38	26	14
10	5/26/2022	35	23	14	2	58	46	27	15
11	5/25/2022	49	37	15	3	49	37	53	41
12	5/24/2022	20	8	15	3	18	6	69	57
13	5/23/2022	15	3	47	35	74	62	31	19
14	5/22/2022	29	17	36	24	61	49	43	31
15	5/21/2022	29	17	77	65	75	63	35	23
16	5/20/2022	49	37	69	57	48	36	45	33
17	5/19/2022	66	54	70	58	13	1	16	4
18	5/18/2022	70	58	40	28	29	17	24	12
19	5/17/2022	65	53	78	66	65	53	52	40
20	5/16/2022	15	3	25	13	38	26	80	68
21	5/15/2022	21	9	31	19	20	8	42	30
22	5/14/2022	36	24	60	48	47	35	69	57
23	5/13/2022	44	32	16	4	56	44	25	13
24	5/12/2022	72	60	16	4	27	15	48	36
25	5/11/2022	33	21	74	62	37	25	35	23
26	5/10/2022	52	40	18	6	68	56	77	65
27	5/9/2022	59	47	74	62	37	25	58	46
28	5/8/2022	36	24	63	51	48	36	47	35
29	5/7/2022	36	24	59	47	13	1	21	9
30	5/6/2022	35	23	33	21	78	66	59	47
Sheet1

 

[Jon Peltier]

I hope you mean every second COLUMN of data. Anyway, the following will do what you want. Adjust the constants at the top of the procedure to manipulate the chart positions.

Sub ChartMaker()
  Const ChartLeft As Double = 325
  Const ChartTop As Double = 10
  Const ChartWidth As Double = 600
  Const ChartHeight As Double = 300
  Const ChartGap As Double = 25
  
  Worksheets("Charts").Activate
  
  Dim DataRange As Range
  Set DataRange = ActiveSheet.UsedRange
  
  Dim XRange As Range
  With DataRange
    Set XRange = .Offset(1).Resize(.Rows.Count - 1, 1)
  End With

  Dim nCharts As Long
  nCharts = (DataRange.Columns.Count - 1) / 2
  
  Dim iChart As Long
  For iChart = 1 To nCharts
    Dim YRange As Range
    Set YRange = XRange.Offset(, 2 * iChart - 1)
    Dim SeriesName As Range
    Set SeriesName = YRange.Offset(-1).Resize(1)
    
    Dim ThisChart As Chart
    Set ThisChart = ActiveSheet.Shapes.AddChart2(, xlXYScatterLines, ChartLeft, _
      ChartTop + (ChartHeight + ChartGap) * (iChart - 1), ChartWidth, ChartHeight).Chart
    
    ThisChart.SetSourceData Union(XRange, YRange)
    ThisChart.SeriesCollection(1).Name = "=" & SeriesName.Address(, , , True)
    ThisChart.Parent.Name = SeriesName.Value2
  Next

End Sub

 

[GeeWhiz7]

Hi folks,
I am not very versant with chart objects and keep getting stuck with the following problem. Thanks for your help!

I have put a simple version of a minisheet below with data. I could not figure out how to capture the charts in the minisheet so an image of the "desired result" is also uploaded.

What I am trying to do.

• I want to automatically create scatter charts for every second row of data where the the X data is always the A1 (Date) column, but the Y data is every nth+2 column (Tons).
• Add chart title that equals the header value for that column
• Put the chart below the previous chart offset by some increment to the top so they are evenly spaced
• Make the chart object name equal also to the header name so that by the end of the loop each chart object has its own name so I can reference them elsewhere.

I tried to loop a macro recording by copying a "template" chart then assigning the source data, but can't quite get things to work as I have not had any experience with chart objects and the syntax.

What I was thinking...but does not work

Sub ChartMaker()

Dim rng As Range
Dim rowNum As Long
Dim topInc As Long


Sheets("Charts").Activate

rowNum = 2
topInc = 300

For Each rng In Range("B2:I2").Columns
  
    Dim chartObj As ChartObject
    Dim refChart As Chart
    
    Set chartObj = ActiveSheet.ChartObjects.Add(Top:=10 + topInc, Left:=325, Width:=600, Height:=300) 'place the next chart incrementally below the previous chart until all charts are made..
    Set refChart = chartObj.Chart
    refChart.ChartType = xlXYScatter
    refChart.SetSourceData Source:=Range(Cells(2, rowNum), Cells(30, 2)) 'Getting lost here, I dont quite know how to set X (date) and Y data separately
  
    ActiveChart.SetElement (msoElementChartTitleAboveChart)
        ActiveChart.ChartTitle.Text = Cell(2, rowNum) 'Trying to add chart title equal to the header like A Tons or B Tons
  
    With Chart
        .Parent.Name = rowNum 'would like chart object name to be equal to the header like A_Tons or B_Tons, etc

    End If
  
rowNum = rowNum + 2 'idea is to make a chart for every second row.

Next rng

End Sub

Book2.xlsx
	A	B	C	D	E	F	G	H	I
1	Date	A Tons	A Over	B Tons	B Over	C Tons	C Over	D Tons	D Over
2	6/3/2022	13	1	59	47	27	15	38	26
3	6/2/2022	13	1	14	2	15	3	42	30
4	6/1/2022	42	30	17	5	29	17	26	14
5	5/31/2022	63	51	33	21	41	29	67	55
6	5/30/2022	50	38	52	40	23	11	13	1
7	5/29/2022	41	29	46	34	38	26	74	62
8	5/28/2022	80	68	14	2	70	58	67	55
9	5/27/2022	15	3	13	1	50	38	26	14
10	5/26/2022	35	23	14	2	58	46	27	15
11	5/25/2022	49	37	15	3	49	37	53	41
12	5/24/2022	20	8	15	3	18	6	69	57
13	5/23/2022	15	3	47	35	74	62	31	19
14	5/22/2022	29	17	36	24	61	49	43	31
15	5/21/2022	29	17	77	65	75	63	35	23
16	5/20/2022	49	37	69	57	48	36	45	33
17	5/19/2022	66	54	70	58	13	1	16	4
18	5/18/2022	70	58	40	28	29	17	24	12
19	5/17/2022	65	53	78	66	65	53	52	40
20	5/16/2022	15	3	25	13	38	26	80	68
21	5/15/2022	21	9	31	19	20	8	42	30
22	5/14/2022	36	24	60	48	47	35	69	57
23	5/13/2022	44	32	16	4	56	44	25	13
24	5/12/2022	72	60	16	4	27	15	48	36
25	5/11/2022	33	21	74	62	37	25	35	23
26	5/10/2022	52	40	18	6	68	56	77	65
27	5/9/2022	59	47	74	62	37	25	58	46
28	5/8/2022	36	24	63	51	48	36	47	35
29	5/7/2022	36	24	59	47	13	1	21	9
30	5/6/2022	35	23	33	21	78	66	59	47
Sheet1

I hope you mean every second COLUMN of data. Anyway, the following will do what you want. Adjust the constants at the top of the procedure to manipulate the chart positions.

Sub ChartMaker()
  Const ChartLeft As Double = 325
  Const ChartTop As Double = 10
  Const ChartWidth As Double = 600
  Const ChartHeight As Double = 300
  Const ChartGap As Double = 25
 
  Worksheets("Charts").Activate
 
  Dim DataRange As Range
  Set DataRange = ActiveSheet.UsedRange
 
  Dim XRange As Range
  With DataRange
    Set XRange = .Offset(1).Resize(.Rows.Count - 1, 1)
  End With

  Dim nCharts As Long
  nCharts = (DataRange.Columns.Count - 1) / 2
 
  Dim iChart As Long
  For iChart = 1 To nCharts
    Dim YRange As Range
    Set YRange = XRange.Offset(, 2 * iChart - 1)
    Dim SeriesName As Range
    Set SeriesName = YRange.Offset(-1).Resize(1)
   
    Dim ThisChart As Chart
    Set ThisChart = ActiveSheet.Shapes.AddChart2(, xlXYScatterLines, ChartLeft, _
      ChartTop + (ChartHeight + ChartGap) * (iChart - 1), ChartWidth, ChartHeight).Chart
   
    ThisChart.SetSourceData Union(XRange, YRange)
    ThisChart.SeriesCollection(1).Name = "=" & SeriesName.Address(, , , True)
    ThisChart.Parent.Name = SeriesName.Value2
  Next

End Sub

John, crazy, but I was just on your website Peltiertech.com to help me figure out a way to do some of the chart sizing/movement!! I came up with something different than what you have above, but I can confirm that yours works. Thanks for the solution and the website.

My code which now also works.

Sub AddCharts()
' Adds a scatter chart for every other column
' Change Mod to another number to do all columns or some other division

    Dim rng As Range
    Dim Num As Long
    Dim topInc As Long
    Dim ParName As String
    
    topInc = 200
    
    For Each rng In Range("B2:I2").Columns
    
        If rng.Column Mod 2 = 0 Then
        
            With ActiveSheet.Shapes.AddChart.Chart
                .ChartType = xlXYScatter
                .SeriesCollection.NewSeries
                .Parent.Name = Cells(1, rng.Column).Value
                
                ParName = Cells(1, rng.Column).Value
                                
                With .SeriesCollection(1)
                    .XValues = "=" & ActiveSheet.Name & "!" & _
                        Range(Cells(2, 1), Cells(30, 1)).Address
                    .Name = "=" & ActiveSheet.Name & "!" & _
                        Cells(1, rng.Column).Address
                    .Values = "=" & ActiveSheet.Name & "!" & _
                        Range(Cells(2, rng.Column), Cells(30, rng.Column)).Address
                    
                    With ActiveSheet.ChartObjects(ParName)
                        .Height = 325
                        .Width = 500
                        .Top = 100 + topInc
                        .Left = 100
                    
                    End With
                        
                End With
            
            End With
                        
        End If

    topInc = topInc + 200

    Next rng

End Sub

 

[Jon Peltier]

Yes, many ways to skin that Excel cat.