Macro for copying flexible ranges as pictures to PPT

[RandomGerman]

Dear all,

I have a few experiences in coding VBA for PowerPoint, but this is the first time I have a need in VBA for Excel. (And the first time I'm posting in the Excel section of this helpful forum. Hello to all! :-) )
As VBA for PowerPoint and for Excel might be brothers, but not twins, some of my pieces of code work and others don't.

I am looking for a macro to copy ranges from Excel and paste them as pictures to PowerPoint. I found something Chris (the spreadsheetguru) wrote, which is very close to what I want to do.

I tried two modifications.

The first was an Input box, giving the user the chance to define the range of cells by himself. This part seems to work.

The second: I want to paste to the active slide, not add a new one, which is, what actually happens.


This is where I stand, please have a look at the comments:

Option Explicit
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range To The Active PowerPoint Slide
'SOURCE: Most of it: www.TheSpreadsheetGuru.com - few modifications: Me. :-)
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim Message As String
Dim Title As String
Dim Default As String
Dim myValue As String

Message = "Please enter Range of cells you want to transfer" & vbCrLf & "Examples:" & vbCrLf & "A1:C10 - for a range" & vbCrLf & "or: F42 - for one cell"
Title = "Transfer to PowerPoint - Input box"
Default = "A1:C10"
myValue = InputBox(Message, Title, Default)
    
'Handles if User cancels
    On Error GoTo UserCancels

'Copy Range from Excel
  Set rng = ThisWorkbook.ActiveSheet.Range(myValue)

'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.ActivePresentation

'The next line of code is not what I want.
'I want to define mySlide as the active slide.
'I tried: Set mySlide = ActiveWindow.View.Slide  <= Would work in PPT, but in Excel debugging didn't accept it

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

'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 = False
  
Exit Sub
  
UserCancels:
   Exit Sub
  
End Sub

Finally, I need help for three points:
1. A solution for the active slide problem (marked with a Long comment in the code)
2. An error message in the right moment, in case no PowerPoint presentation is open
3. As there are some parts in Chris' code I must admit I don't understand, I have no idea if they are still necessary after all modifications. Please feel free to optimize and/or clean up anything you see. If there is room for improvement, please improve. :-)


Thanks a lot in advance
RG

[mdmackillop]

You can refer to a SlideNumber but I don't know how to get this in PP for the active slide.

Set mySlide = myPresentation.Slides(2)

Edit:
I found this suggested here

    Set mySlide = PowerPointApp.ActiveWindow.View.Slide

Warning code

     'Create a New Presentation
    On Error Resume Next
    Set myPresentation = PowerPointApp.ActivePresentation
     If Err <> 0 Then
 MsgBox "No open presentation", vbCritical
     Exit Sub
End If
On Error GoTo 0

[RandomGerman]

Set mySlide = PowerPointApp.ActiveWindow.View.Slide

This makes abolute sense. It is exactly the code working in PowerPoint - it is only necessary first to define, that it has to be done in PowerPoint.

Thank you very much, and for the warning code, too. Works great.

[mdmackillop]

I've incorporated the above and reordered some of the events.
If no presentation is active, the code will stop at an open PP allowing you to select your presentation and slide. Excel will be reduced to "Normal" size.
Rerunning the code will add the image to the active slide.

Either Select object to be copied or be prompted for range.

Option ExplicitSub ExcelRangeToPowerPoint()
     'PURPOSE: Copy/Paste An Excel Range To The Active PowerPoint Slide
     'SOURCE: Most of it: www.TheSpreadsheetGuru.com - few modifications: Me. :-)
    Dim rng As Range
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object
    Dim Message As String
    Dim Title As String
    Dim Default As String
    Dim myValue As String
    Dim Typ As String
     
     'Is PowerPoint already opened?
    On Error Resume Next
    Set PowerPointApp = GetObject(class:="PowerPoint.Application")
     'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
     'Open Presentation
    Set myPresentation = PowerPointApp.ActivePresentation
     'If no active presentation
    If Err <> 0 Then
         'Normalise Excel window and make PowerPoint Visible and Active to choose Presentation
        ActiveWindow.WindowState = xlNormal
        PowerPointApp.Visible = True
        PowerPointApp.Activate
        Exit Sub
    End If
    On Error GoTo 0
    
    Typ = TypeName(Selection)
    If Typ = "Range" Then
        Message = "Please enter Range of cells you want to transfer" & vbCrLf & "Examples:" & vbCrLf & "A1:C10 - for a range" & vbCrLf & "or: F42 - for one cell"
        Title = "Transfer to PowerPoint - Input box"
        Default = "A1:P30"
        myValue = InputBox(Message, Title, Default)
         'Handles if User cancels
        On Error GoTo UserCancels
         'Copy Range from Excel
        Set rng = ThisWorkbook.ActiveSheet.Range(myValue)
         'Optimize Code
        Application.ScreenUpdating = False
         'Copy Excel Range
        rng.Copy
    Else
        Selection.Copy
    End If
        
     'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate
     'Set mySlide = myPresentation.Slides(2)
    Set mySlide = PowerPointApp.ActiveWindow.View.Slide
     'Paste to PowerPoint and position
    
    If Typ = "ChartArea" Then
        mySlide.Shapes.PasteSpecial DataType:=6 '6= ppPastePNG
    Else
        mySlide.Shapes.PasteSpecial DataType:=2 '2= ppPasteEnhancedMetafile
    End If
    
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
     'Set position:
    myShape.Left = 66
    myShape.Top = 152
     'Clear The Clipboard
    Application.CutCopyMode = False
UserCancels:
    Exit Sub
End Sub

[RandomGerman]

Wow, this is really impressive! Thank you for the time to improve the macro! I think this version is helpful for anybody who has to transfer a lot of data from Excel to PPT.