Just a thought here - to reduce code and make it more manageable, would it be
better to Save As and then remove the content that you don't want to retain
from there?
"Sarah (OGI)" wrote:
> I've got the following code which exports all sheets containing charts to a
> new workbook. Each sheet name is also copied across, as well as all summary
> information.
>
> I've now added 8 logo's onto each source sheet, therefore in the process of
> copying out the chart sheets, I'd like to be able to copy the new pictures
> (inc. the size, position, etc) as well.
>
> Any ideas as to how I might be able to do this?
>
> =================
>
> Sub CopyChart()
> Dim ChartBook As Workbook, SourceBook As Workbook
> Dim TmpSheets As Integer, wkSheet As Worksheet
> Dim ChartObj, ChartCount As Long
>
> Set SourceBook = ActiveWorkbook
>
> For Each wkSheet In SourceBook.Sheets
> If wkSheet.ChartObjects.Count > 0 Then
> ChartCount = ChartCount + 1
> End If
> Next
>
> If ChartCount < 1 Then Exit Sub
>
> TmpSheets = Application.SheetsInNewWorkbook
> Application.SheetsInNewWorkbook = ChartCount
> Set ChartBook = Workbooks.Add
> Application.SheetsInNewWorkbook = TmpSheets
> TmpSheets = 1
>
> For Each wkSheet In SourceBook.Sheets
> If wkSheet.ChartObjects.Count > 0 Then
> With ChartBook.Sheets(TmpSheets)
> .Activate
> .Name = wkSheet.Name
> wkSheet.Cells.Copy
> .Cells.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
> False, Transpose:=False
> .Cells.PasteSpecial Paste:=xlFormats, Operation:=xlNone,
> SkipBlanks:= _
> False, Transpose:=False
> '.Paste
> '.Cells.PasteSpecial Paste:=xlValues, Operation:=xlNone,
> SkipBlanks:=False, Transpose:=False
> .ChartObjects.Delete
> End With
> ChartCount = 1
> For Each ChartObj In wkSheet.ChartObjects
> ChartObj.CopyPicture Appearance:=xlScreen, Format:=xlPicture
> ChartBook.Sheets(TmpSheets) _
> .PasteSpecial Format:="Picture (Enhanced Metafile)", _
> Link:=False, DisplayAsIcon:=False
> With ChartBook.Sheets(TmpSheets).Shapes(ChartCount)
> .Top = ChartObj.Top
> .Left = ChartObj.Left
> End With
> ChartCount = ChartCount + 1
> Next
> TmpSheets = TmpSheets + 1
> End If
> Range("A1").Select
> Next
>
> End Sub
> ==================
|
Similar Threads
