How to copy Excel ranges to Powerpoint slides with VBA

[waimea]

Hi,

I am trying to copy multiple ranges in excel into multiple powerpoint slides without success.

I have the following code that works for one range, taken from https://www.thespreadsheetguru.com/blog/2014/3/17/copy-paste-an-excel-range-into-powerpoint-with-vba

The code below does what I want for one slide, I have a total of #12 slides that I want to create from my Excel file.

Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com


Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object


'Copy Range from Excel
  Set rng = ThisWorkbook.ActiveSheet.Range("A1:C12")


'Create an Instance of PowerPoint
  On Error Resume Next
    
    'Is PowerPoint already opened?
      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


'Optimize Code
  Application.ScreenUpdating = False
  
'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add


'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly


'Copy Excel Range
  rng.Copy


'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  
    'Set position:
      myShape.Left = 0
      myShape.Top = 0


'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate


'Clear The Clipboard
  Application.CutCopyMode = False
  
End Sub

How can I adapt this code to work with multiple ranges? All of my ranges are in the same worksheet, on sheet19.

[Kenneth Hobs]

What are the ranges?

[waimea]

Hi Kenneth,

thank you for your reply. The ranges are on sheet19 and the first 3 ranges are ("D7:I39"), ("D42:I73"), ("D75:I106").

I would like to learn how to add more ranges myself if that makes sense, so if you can show me how to add the 3 ranges and then I can add the rest of them?

[Kenneth Hobs]

It should be something close to this. You will need to add some shape resize parts or such.

I added early binding to make it easier for you to add to this. Add the reference in VBE's Tools > References.

'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com
Sub Main()
  Dim ar As Range, r As Range
  'Dim PowerPointApp As Object, myPresentation As Object
  'Dim mySlide As Object, myShape As Object
  Dim PowerPointApp As PowerPoint.Application, myPresentation As Presentation
  Dim mySlide As Slide, myShape As PowerPoint.Shape


'Create an Instance of PowerPoint
  On Error Resume Next
  'Is PowerPoint already opened?
  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
  'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add
  
  Set r = Worksheets("Sheet19").Range("D7:I39,D42:I73,D75:I106")
  For Each ar In r.Areas
    'Add a slide to the Presentation
    Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
    'Copy Excel Range
    ar.Copy


    'Paste to PowerPoint and position
    mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    
    'Set position:
    myShape.Left = 0
    myShape.Top = 0
  Next ar
  
  'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate




  'Clear The Clipboard
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

[waimea]

Hi Kenneth,

thank you for your reply and your code, which works great!

I have a question about early binding, if I send the file to someone else, do they have to add the reference?

[Kenneth Hobs]

They would have to have the same version of the object referenced. e.g. PPT 365 vs. PPT 2016, 2013, etc. That is why some code early but production version use late. This is why I left the late binding objects commented. Simply delete or comment out the two lines of early bound objects and uncomment the late bound object lines.

[waimea]

Hi Kenneth,

thank you for your reply and for the advice on binding!

I got it both bindings to work!