Using VBA to copy from Excel to an open Powerpoint presentation - vba

Question

I know that this question has been asked in similar ways before but I am very new to coding and am finding it very difficult to understand the language used in some of the other posts.
Essentially the task is to copy a row of data from one excel spreadsheet into another that creates charts from that single row.
It creates 6 charts in total and these all need to be copied to an powerpoint presentation, 4 of them one slide and the other 2 on the next.
Then the code should loop back to the beginning and begin the process again but with the next row of data pasting the results of this iteration to 2 new slides.
I have managed to write enough code to take the data from excel convert it to the charts and then export it to powerpoint but it always copies to a new powerpoint presentation rather than a new slide and I need it to copy to an active presentation. Here is the code:
Sub Tranposer()
'
' Tranposer Macro
' Copies and Transposes answers to the graph calculator
'
' Keyboard Shortcut: Ctrl+h
'
Windows("Data Spreadsheet.xlsx").Activate
Rows("2:2").Select
Selection.Copy
Windows("Graph Spreadsheet.xlsm").Activate
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
'Copy Excel Range
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveChart.ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Copy Excel Range
ActiveSheet.ChartObjects("Chart 7").Activate
ActiveChart.ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Copy Excel Range
ActiveSheet.ChartObjects("Chart 5").Activate
ActiveChart.ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Copy Excel Range
ActiveSheet.ChartObjects("Chart 4").Activate
ActiveChart.ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Copy Excel Range
ActiveSheet.ChartObjects("Chart 6").Activate
ActiveChart.ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Copy Excel Range
ActiveSheet.ChartObjects("Chart 9").Activate
ActiveChart.ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
I know this is a lot of code and I know that I could loop through the charts the save time but I don't know how to loop yet so I am currently comfortable with leaving that how it is. Can anyone help me with my exporting to powerpoint?

Answer 1

If I understood well, you want to loop to select the next row in your Data Spreadsheet to copy/paste it into your Graph Spreadsheet and then paste the 6 charts (on 2 slides) for each row into the same presentation.
Here is your code reviewed to do that (modifications/options below code) :
Sub Tranposer()
'
' Tranposer Macro
' Copies and Transposes answers to the graph calculator
'
' Keyboard Shortcut: Ctrl+h
'
Dim PowerPointApp As PowerPoint.Application, _
myPresentation As PowerPoint.Presentation, _
mySlide As PowerPoint.Slide, _
myShapeRange As PowerPoint.Shape, _
WsData As Worksheet, _
WsGraph As Worksheet
Set WsData = Workbooks("Data Spreadsheet.xlsx").ActiveSheet
Set WsGraph = Workbooks("Graph Spreadsheet.xlsm").ActiveSheet
On Error Resume Next
'Is PowerPoint already opened?
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
'Set myPresentation = PowerPointApp.Presentations.Add
'Or Open an EXISTING one
Set myPresentation = PowerPointApp.Presentations.Open("C:\Test\Ppt_Test.pptx")
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count, ppLayoutTitleOnly)
For i = 2 To 5 'WsData.Range("A" & WsData.Rows.Count).End(xlUp).Row
WsData.Rows(i & ":" & i).Copy
WsGraph.Range("B1").PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
'Copy Excel Range
WsGraph.ChartObjects("Chart 1").ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Copy Excel Range
WsGraph.ChartObjects("Chart 7").ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Copy Excel Range
WsGraph.ChartObjects("Chart 5").ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Copy Excel Range
WsGraph.ChartObjects("Chart 4").ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Add a new slide
Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count, ppLayoutTitleOnly)
'Copy Excel Range
WsGraph.ChartObjects("Chart 6").ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'Copy Excel Range
WsGraph.ChartObjects("Chart 9").ChartArea.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Next i
'Clear The Clipboard
Application.CutCopyMode = False
'Set = Nothing : Free named Object-variables
Set PPApp = Nothing
Set PPPres = Nothing
Set PowerPointApp = Nothing
Set myPresentation = Nothing
Set mySlide = Nothing
Set WsData = Nothing
Set WsGraph = Nothing
End Sub
First, you need to specify the name of your sheets in here Set WsData = Workbooks("Data Spreadsheet.xlsx").ActiveSheet, like this Set WsData = Workbooks("Data Spreadsheet.xlsx").Sheets("Sheet_Name").
Then you can either create a new presentation with Set myPresentation = PowerPointApp.Presentations.Add or open an EXISTING one with Set myPresentation = PowerPointApp.Presentations.Open("C:\Test\Ppt_Test.pptx").
For the loop, for the moment, it is set to loop from row 2 to row 5 in your Data Spreadsheet with For i = 2 To 5, but you can loop all the way to the last row of data by getting rid of the 5 and replace it by WsData.Range("A" & WsData.Rows.Count).End(xlUp).Row
Finally, don't forget to free your Object-variable by setting them as Nothing.
Btw, I got rid of the useless Select and Activate that are very greedy in resources for almost nothing most of the time.