Hi,
I got the following code from the net. Can anyone please tweak it for me to copy and paste multiple charts and ranges in this?
and take a template which I will be storing in D Drive?
2 more things, I need to paste the range and charts at the same time. chart on top and range below. Will be great if I can adjust the position of that in the macro
PHP Code:
Sub Copy_Paste_to_PowerPoint()
'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE Dim ppApp As PowerPoint.Application Dim ppSlide As PowerPoint.Slide
'Original code sourced from Jon Peltier http://peltiertech.com/Excel/XL_PPT.html 'This code developed at http://oldlook.experts-exchange.com:8080/Applications/MS_Office/Excel/Q_21337053.html
Dim SheetName As String Dim TestRange As Range Dim TestSheet As Worksheet Dim TestChart As ChartObject
Dim PasteChart As Boolean Dim PasteChartLink As Boolean Dim ChartNumber As Long
Dim PasteRange As Boolean Dim RangePasteType As String Dim RangeName As String Dim AddSlidesToEnd As Boolean
'Parameters
'SheetName - name of sheet in Excel that contains the range or chart to copy
'PasteChart -If True then routine will copy and paste a chart 'PasteChartLink -If True then Routine will paste chart with Link; if = False then paste chart no link 'ChartNumber -Chart Object Number ' 'PasteRange - If True then Routine will copy and Paste a range 'RangePasteType - Paste as Picture linked or unlinked, "HTML" or "Picture". See routine below for exact values 'RangeName - Address or name of range to copy; "B3:G9" "MyRange" 'AddSlidesToEnd - If True then appednd slides to end of presentation and paste. If False then paste on current slide.
'use active sheet. This can be a direct sheet name SheetName = ActiveSheet.Name
'Setting PasteRange to True means that Chart Option will not be used PasteRange = True RangeName = "MyRange" RangePasteType = "HTML" RangeLink = True
'Error testing On Error Resume Next Set TestSheet = Sheets(SheetName) Set TestRange = Sheets(SheetName).Range(RangeName) Set TestChart = Sheets(SheetName).ChartObjects(ChartNumber) On Error Goto 0
If TestSheet Is Nothing Then MsgBox "Sheet " & SheetName & " does not exist. Macro will exit", vbCritical Exit Sub End If
If PasteRange And TestRange Is Nothing Then MsgBox "Range " & RangeName & " does not exist. Macro will exit", vbCritical Exit Sub End If
If PasteRange = False And PasteChart And TestChart Is Nothing Then MsgBox "Chart " & ChartNumber & " does not exist. Macro will exit", vbCritical Exit Sub End If
'Look for existing instance On Error Resume Next Set ppApp = GetObject(, "PowerPoint.Application") On Error Goto 0
'Create new instance if no instance exists If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application 'Add a presentation if none exists If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add
'Make the instance visible ppApp.Visible = True
'Check that a slide exits, if it doesn't add 1 slide. Else use the last slide for the paste operation If ppApp.ActivePresentation.Slides.Count = 0 Then Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, ppLayoutBlank) Else If AddSlidesToEnd Then 'Appends slides to end of presentation and makes last slide active ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank ppApp.ActiveWindow.View.GotoSlide ppApp.ActivePresentation.Slides.Count Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count) Else 'Sets current slide to active slide Set ppSlide = ppApp.ActiveWindow.View.Slide End If End If
'Options for Copy & Paste Ranges and Charts If PasteRange = True Then 'Options for Copy & Paste Ranges If RangePasteType = "Picture" Then 'Paste Range as Picture Worksheets(SheetName).Range(RangeName).Copy ppSlide.Shapes.PasteSpecial(ppPasteDefault, link:=RangeLink).Select Else 'Paste Range as HTML Worksheets(SheetName).Range(RangeName).Copy ppSlide.Shapes.PasteSpecial(ppPasteHTML, link:=RangeLink).Select End If Else 'Options for Copy and Paste Charts Worksheets(SheetName).Activate ActiveSheet.ChartObjects(ChartNumber).Select If PasteChartLink = True Then 'Copy & Paste Chart Linked ActiveChart.ChartArea.Copy ppSlide.Shapes.PasteSpecial(link:=True).Select Else 'Copy & Paste Chart Not Linked ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture ppSlide.Shapes.Paste.Select End If End If
'Center pasted object in the slide ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
AppActivate ("Microsoft PowerPoint") Set ppSlide = Nothing Set ppApp = Nothing
End Sub
Thanks for your help in advance
Last edited by akhileshgs; 06-02-2014 at 07:36 AM.
Please make the Post as solved, when you get your answer & Click * if you like my suggestion
'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE Dim PPApp As PowerPoint.Application Dim PPSlide As PowerPoint.Slide
'Original code sourced from Jon Peltier http://peltiertech.com/Excel/XL_PPT.html 'This code developed at http://oldlook.experts-exchange.com:8080/Applications/MS_Office/Excel/Q_21337053.html
Dim SheetName As String Dim TestRange As Range Dim TestSheet As Worksheet Dim TestChart As ChartObject
Dim PasteChart As Boolean Dim PasteChartLink As Boolean Dim ChartNumber As Long
Dim PasteRange As Boolean Dim RangePasteType As String Dim RangeName As String Dim AddSlidesToEnd As Boolean Dim PPT As PowerPoint.Application Set PPT = New PowerPoint.Application
'Parameters
'SheetName - name of sheet in Excel that contains the range or chart to copy
'PasteChart -If True then routine will copy and paste a chart 'PasteChartLink -If True then Routine will paste chart with Link; if = False then paste chart no link 'ChartNumber -Chart Object Number ' 'PasteRange - If True then Routine will copy and Paste a range 'RangePasteType - Paste as Picture linked or unlinked, "HTML" or "Picture". See routine below for exact values 'RangeName - Address or name of range to copy; "B3:G9" "MyRange" 'AddSlidesToEnd - If True then appednd slides to end of presentation and paste. If False then paste on current slide.
'use active sheet. This can be a direct sheet name SheetName = ActiveSheet.Name
'Setting PasteRange to True means that Chart Option will not be used PasteRange = True
'Error testing On Error Resume Next Set TestSheet = Sheets(SheetName) Set TestRange = Sheets(SheetName).Range(RangeName) Set TestChart = Sheets(SheetName).ChartObjects(ChartNumber) On Error GoTo 0
If TestSheet Is Nothing Then MsgBox "Sheet " & SheetName & " does not exist. Macro will exit", vbCritical Exit Sub End If
If PasteRange And TestRange Is Nothing Then MsgBox "Range " & RangeName & " does not exist. Macro will exit", vbCritical Exit Sub End If
If PasteRange = False And PasteChart And TestChart Is Nothing Then MsgBox "Chart " & ChartNumber & " does not exist. Macro will exit", vbCritical Exit Sub End If
'Look for existing instance On Error Resume Next Set PPApp = GetObject(, "PowerPoint.Application") On Error GoTo 0
'Create new instance if no instance exists If PPApp Is Nothing Then Set PPApp = New PowerPoint.Application 'Add a presentation if none exists If PPApp.Presentations.Count = 0 Then PPApp.Presentations.Add
'Make the instance visible PPApp.Visible = True
'Check that a slide exits, if it doesn't add 1 slide. Else use the last slide for the paste operation If PPApp.ActivePresentation.Slides.Count = 0 Then PPT.Presentations.Open Filename:="D:\DU Dashboard Template.pptx"
Else If AddSlidesToEnd Then 'Appends slides to end of presentation and makes last slide active PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count Set PPSlide = PPApp.ActivePresentation.Slides(PPApp.ActivePresentation.Slides.Count) Else 'Sets current slide to active slide Set PPSlide = PPApp.ActiveWindow.View.Slide End If End If
'Options for Copy & Paste Ranges and Charts
If RangePasteType = "Picture" Then 'Paste Range as Picture Worksheets(SheetName).Range(RangeName).Copy
'Options for Copy and Paste Charts Worksheets(SheetName).Activate ActiveSheet.ChartObjects(ChartNumber).Select If PasteChartLink = True Then 'Copy & Paste Chart Linked ActiveChart.ChartArea.Copy PPSlide.Shapes.PasteSpecial(Link:=False).Select Else 'Copy & Paste Chart Not Linked ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture PPSlide.Shapes.Paste.Select End If
'Center pasted object in the slide PPApp.ActiveWindow.Selection.ShapeRange.Top = 80 PPApp.ActiveWindow.Selection.ShapeRange.Left = 15 With PPApp.ActiveWindow.Selection.ShapeRange .Top = 40 ' points .Left = 40
End With AppActivate ("Microsoft PowerPoint") Set PPSlide = Nothing Set PPApp = Nothing
End Sub
make seperate modules for each range and charts and call them from the summary sheet.
How to get it with a single macro?
Last edited by akhileshgs; 06-02-2014 at 10:54 AM.
Bookmarks