Copying Charts: CODE NOT ROBUST

[WhytheQ]

Can anyone help.
The code I'm using is:

Dim sheet
Dim Chart

'loop through all the embedde charts in a particular sheet
For Each Chart In sheet.ChartObjects

'activate the chart and move it to it's own sheet
Chart.Activate
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:=mySheetName

'now copy the chart worksheet to a different workbook
ActiveSheet.Copy
Workbooks(myFileName).Sheets(Workbooks(myFileName).Sheets.Count)

'in thisworkbook move the chart back to being an embedded chart object
ThisWorkbook.Activate
ActiveChart.Location Where:=xlLocationAsObject, Name:=sheet.Name

Next Chart

I've used the above procedure because I just want the charts to be
embedded objects in the main spreadsheet rather than having a load of
Chartsheets aswell as worksheets.
Problem with the above is that it seems to throw an unknown error, and
then when I go into the code window and go for Debug and then step
through the macro all seems ok: but when I come to exit the spreadsheet
and save changes a nasty Dr Watson occurs - and all Excel is lost.
So I believe the above is doing something particularly nasty to Excel.

Any help greatly appreciated
Jason.

 

[Tom Ogilvy]

Here is a possible workaround:

dim sht as Worksheet
Dim cobj as ChartObject
Dim cobj1 as ChartObject
set sht = Activesheet
For Each cObj In sheet.ChartObjects
sht.copy ' makes a new workbook with all chart Objects
' now delete all but the one you want
for each cobj1 in activesheet.ChartObjects
if cobj1.name <> cObj.Name then
cobj1.Delete
end if
next
ActiveWorkbook.SaveAs "C:\Myfolder\" & cobj.Name & ".xls"
ActiveWorkbook.Close Savechanges:=False
Next

 

[WhytheQ]

cheers Tom
Jason

Here is a possible workaround:

dim sht as Worksheet
Dim cobj as ChartObject
Dim cobj1 as ChartObject
set sht = Activesheet
For Each cObj In sheet.ChartObjects
sht.copy ' makes a new workbook with all chart Objects
' now delete all but the one you want
for each cobj1 in activesheet.ChartObjects
if cobj1.name <> cObj.Name then
cobj1.Delete
end if
next
ActiveWorkbook.SaveAs "C:\Myfolder\" & cobj.Name & ".xls"
ActiveWorkbook.Close Savechanges:=False
Next