Using VBA to copy from Excel to an open Powerpoint presentation

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.