How to copy charts from multiple sheets and save it as chart title

[EileenJohn]

Hi, I'm trying to copy charts from workbookA (sheets1, sheets3 and Sheets4) to .png and save the charts based on chart title
(TotalStaff, Factory5, LeaveMonthly).
But now I only manage to get chart from 1 sheets.
My code:
Sub CopyChart()
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("Factory5").Range("A1:Q21")
Set ShTemp = Worksheets.Add
DoEvents
Charts.Add
Application.DisplayAlerts = False
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
DoEvents
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 540
.Height = PicTemp.Height + 310
End With
ChTemp.Export Filename:="D:\Charts\Factory5.png", FilterName:="png"
ShTemp.Delete
Application.ScreenUpdating = True
End Sub

How to change this code? Should i use select case? For? How to save it according to chart title? Any ideas? Thanks in advance.

 

[Worf]

Hi

Sub CopyChart()
Dim pic_rng As Range, ShTemp As Worksheet, ChTemp As Chart, _
PicTemp As Picture, tit, sn, i%
sn = Array("sheet1", "sheet3", "sheet4")
tit = Array("TotalStaff", "Factory5", "LeaveMonthly")
Set ShTemp = Worksheets.Add
For i = LBound(sn) To UBound(sn)
    Set pic_rng = Worksheets(sn(i)).[A1:Q21]                    ' variable sheet
    DoEvents
    Charts.Add
    Application.DisplayAlerts = False
    ActiveChart.Location xlLocationAsObject, ShTemp.Name
    Set ChTemp = ActiveChart
    ChTemp.HasTitle = True
    ChTemp.ChartTitle.Text = tit(i)
    pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    DoEvents:    ChTemp.Paste
    Set PicTemp = Selection
    With ChTemp.Parent
        .Width = PicTemp.Width + 540
        .Height = PicTemp.Height + 310
    End With
    ChTemp.Export "c:\pub\" & tit(i) & ".png", "png"            ' variable file name
    DoEvents: ShTemp.[a1].Activate
    ShTemp.ChartObjects(1).Delete
Next
ShTemp.Delete
End Sub

 

[EileenJohn]

Hi

Sub CopyChart()
Dim pic_rng As Range, ShTemp As Worksheet, ChTemp As Chart, _
PicTemp As Picture, tit, sn, i%
sn = Array("sheet1", "sheet3", "sheet4")
tit = Array("TotalStaff", "Factory5", "LeaveMonthly")
Set ShTemp = Worksheets.Add
For i = LBound(sn) To UBound(sn)
    Set pic_rng = Worksheets(sn(i)).[A1:Q21]                    ' variable sheet
    DoEvents
    Charts.Add
    Application.DisplayAlerts = False
    ActiveChart.Location xlLocationAsObject, ShTemp.Name
    Set ChTemp = ActiveChart
    ChTemp.HasTitle = True
    ChTemp.ChartTitle.Text = tit(i)
    pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    DoEvents:    ChTemp.Paste
    Set PicTemp = Selection
    With ChTemp.Parent
        .Width = PicTemp.Width + 540
        .Height = PicTemp.Height + 310
    End With
    ChTemp.Export "c:\pub\" & tit(i) & ".png", "png"            ' variable file name
    DoEvents: ShTemp.[a1].Activate
    ShTemp.ChartObjects(1).Delete
Next
ShTemp.Delete
End Sub

Thanks worf