Trying to Learn Code to Copy Charts

[PHisaw]

Hi,

I have the following code to copy two charts from 'Bookings' sheet and paste
to several other sheets along with other details after the paste on each
sheet. I used the macro recorder to do this as I am so new to vba and took
out what I thought wound not be needed. It works as I want, but as you can
see the code repeats itself for every sheet. There will be 12 in all. Can
someone teach me how to group all the 'paste to' sheets and still have it
update with the correct source data for each chart on each sheet? I have the
two lines of code that are in question flagged below.

Sub ChartCopyCode()
'
Sheets("Bookings").Select
ActiveSheet.Shapes.Range(Array(1, 2)).Select
Selection.Copy

Sheets("Bk01-09").Select
Columns("R:R").ColumnWidth = 20
Columns("Y:Y").ColumnWidth = 20
Range("Q1").Select
ActiveSheet.Paste
ActiveSheet.Shapes(1).ScaleHeight 1#, msoFalse, msoScaleFromTopLeft
ActiveSheet.ChartObjects(2).Activate

***** ActiveChart.SetSourceData
Source:=Sheets("Bk01-09").Range("W2:Y17"), PlotBy _
:=xlColumns

ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).DataLabels.Select
With Selection.Font
.Name = "Arial"
.Size = 7
End With
ActiveChart.SeriesCollection(1).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
With ActiveChart.Axes(xlCategory)
.ReversePlotOrder = True
.Crosses = xlMaximum
End With
With ActiveChart.Axes(xlCategory).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart.Axes(xlValue).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Vendor Monthly Bookings "
End With

ActiveSheet.ChartObjects(1).Activate

**** ActiveChart.SetSourceData
Source:=Sheets("Bk01-09").Range("W21:Y31"), PlotBy _
:=xlColumns

ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).DataLabels.Select
With Selection.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart.Axes(xlCategory)
.ReversePlotOrder = True
.Crosses = xlMaximum
End With
With ActiveChart.Axes(xlCategory).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart.Axes(xlValue).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Slsp Monthly Bookings "
End With

Sheets("Bk02-09").Select
Columns("R:R").ColumnWidth = 20
Columns("Y:Y").ColumnWidth = 20
Range("Q1").Select
ActiveSheet.Paste
ActiveSheet.Shapes(1).ScaleHeight 1#, msoFalse, msoScaleFromTopLeft
ActiveSheet.ChartObjects(2).Activate

***** ActiveChart.SetSourceData Source:=Sheets("Bk02-09").Range("W2:Y17"),
PlotBy _
:=xlColumns

ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).DataLabels.Select
With Selection.Font
.Name = "Arial"
.Size = 7
End With
ActiveChart.SeriesCollection(1).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
With ActiveChart.Axes(xlCategory)
.ReversePlotOrder = True
.Crosses = xlMaximum
End With
With ActiveChart.Axes(xlCategory).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart.Axes(xlValue).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Vendor Monthly Bookings "
End With

ActiveSheet.ChartObjects(1).Activate

**** ActiveChart.SetSourceData Source:=Sheets("Bk02-09").Range("W21:Y31"),
PlotBy _
:=xlColumns

ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).DataLabels.Select
With Selection.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart.Axes(xlCategory)
.ReversePlotOrder = True
.Crosses = xlMaximum
End With
With ActiveChart.Axes(xlCategory).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart.Axes(xlValue).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Slsp Monthly Bookings "
End With
End Sub

Any help with be greatly appreciated.
Thanks in advance.
Phisaw

 

[Per Jessen]

Hi

You can create an array variable, with all sheet names to paste to.
Then you can use a loop to paste charts and change the sheet
reference:

Sub ChartCopyCode()
'
Dim ShArr
ShArr = Split("Bk01-09,Bk02-09,Bk03-09", ",")
Sheets("Bookings").Shapes.Range(Array(1, 2)).Copy
For c = LBound(ShArr) To UBound(ShArr)

Sheets(ShArr(c)).Select
Columns("R:R").ColumnWidth = 20
Columns("Y:Y").ColumnWidth = 20
Range("Q1").Select
ActiveSheet.Paste
ActiveSheet.Shapes(1).ScaleHeight 1#, msoFalse,
msoScaleFromTopLeft
ActiveSheet.ChartObjects(2).Activate
ActiveChart.SetSourceData Source:=Sheets(ShArr(c)).Range
("W2:Y17"), PlotBy _
:=xlColumns
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).DataLabels.Select
With Selection.Font
.Name = "Arial"
.Size = 7
End With
ActiveChart.SeriesCollection(1).Select
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
With ActiveChart.Axes(xlCategory)
.ReversePlotOrder = True
.Crosses = xlMaximum
End With
With ActiveChart.Axes(xlCategory).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart.Axes(xlValue).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Vendor Monthly Bookings "
End With


ActiveSheet.ChartObjects(1).Activate
ActiveChart.SetSourceData Source:=Sheets(ShArr(c)).Range
("W21:Y31"), PlotBy _
:=xlColumns
ActiveChart.SeriesCollection(1).Delete
ActiveChart.SeriesCollection(1).DataLabels.Select
With Selection.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart.Axes(xlCategory)
.ReversePlotOrder = True
.Crosses = xlMaximum
End With
With ActiveChart.Axes(xlCategory).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart.Axes(xlValue).TickLabels.Font
.Name = "Arial"
.Size = 7
End With
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Slsp Monthly Bookings "
End With
Next
Application.CutCopyMode = False
End Sub

Regards,
Per

 

[PHisaw]

Per Jessen,

Thank you for replying with explanation and code to group all sheets in an
array. There was one line of code that gave me an "object does not support
this method" error, so I just pasted what I originally had and it worked.
Still much shorter than all the same code for 12 worksheets.

Here's the line that threw the error:

Sheets("Bookings").Shapes.Range(Array(1, 2)).Copy

and I went back with this:

Sheets("Bookings").Select
Thanks again for your help.
Phisaw