Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Adapt code to copy out pictures as well
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 ================== |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Adapt code to copy out pictures as well
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 ================== |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Adapt code to copy out pictures as well
I'd add a line to this code that would do the picture copying:
.... Call CopyAllPictures End sub You have a response to your picture post. 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 ================== -- Dave Peterson |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Adapt code to show filter | Excel Programming | |||
Adapt code to loop through sheets | Excel Programming | |||
Using Find/Replace in Visual basic to adapt the code | Excel Programming | |||
code for pictures in comments | Excel Programming | |||
Please help me to adapt this code. | Excel Programming |