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 (http://Sub ExcelRangeToPowerPoint() 'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation 'SOURCE: www.TheSpreadsheetGuru.comDim 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 IfOn 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 = 66 myShape.Top = 152'Make PowerPoint Visible and Active PowerPointApp.Visible = True PowerPointApp.Activate'Clear The Clipboard Application.CutCopyMode = FalseEnd Sub)

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! :)