VBA Issue Resizing and Enhanced Meta File Pasted From Excel to PowerPoint

Question

I'm attempting to create an Excel macro which allows me to select any range with an Excel file and export that selection to PowerPoint while matching the size of a selected PowerPoint shape/object. Sometimes this data will be only data tables but sometimes it will be selection of charts and accompanying data tables (hence the decision to export as an Enhanced Meta File).

I've pasted my code below and the issue appears to be occurring at the "turn off aspect ratio" section, as I am able to get the linked meta file pasted into PowerPoint, but the aspect ratio lock remains on and the pasted item does not match the size/location of the selected item in PowerPoint.

Worth noting that I am relatively inexperienced with VBA but do have used it in the past.

Sub ExportToPPT()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPO As PowerPoint.ShapeRange

' Reference instance of PowerPoint
On Error Resume Next
' Check whether PowerPoint is running
Set PPApp = GetObject(, "PowerPoint.Application")
If PPApp Is Nothing Then
    MsgBox "You need to have powerpoint open and an object selected to use this macro"
    Exit Sub
End If
On Error GoTo 0

' Reference presentation and slide
On Error Resume Next
If PPApp.Windows.Count > 0 Then
    ' There is at least one presentation
    ' Use existing presentation
    Set PPPres = PPApp.ActivePresentation
    ' Use active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Set PPO = PPPres.Slides(PPApp.ActiveWindow.Selection.ShapeRange(1))
    x = PPApp.ActiveWindow.Selection.ShapeRange(1).Name
    xx = PPApp.ActiveWindow.Selection.ShapeRange(1).Left
    xy = PPApp.ActiveWindow.Selection.ShapeRange(1).Top
    xh = PPApp.ActiveWindow.Selection.ShapeRange(1).Height
    xw = PPApp.ActiveWindow.Selection.ShapeRange(1).Width
    PPApp.ActiveWindow.Selection.ShapeRange(1).Delete
    'Debug.Print x
End If
On Error GoTo 0

On Error GoTo Whoops

' Copy the range as a picture

Excel.Selection.Copy

Application.Wait (Now + TimeValue("00:00:02"))

' Paste the range
PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoTrue).Select

' Turn off aspect ratio
Dim oSh As PowerPoint.Shape
With PPApp.ActiveWindow.Selection
For Each oSh In .ShapeRange
   oSh.LockAspectRatio = False
Next
End With


' Position pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Left = xx
PPApp.ActiveWindow.Selection.ShapeRange.Top = xy
PPApp.ActiveWindow.Selection.ShapeRange.Height = xh
PPApp.ActiveWindow.Selection.ShapeRange.Width = xw
PPApp.ActiveWindow.Selection.ShapeRange.ZOrder (msoSendToBack)

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

Exit Sub

Whoops:
MsgBox "An error occurred; the transfer was not successful. Please recheck your 
selections in both PowerPoint and Excel and try again.", , "Error copying Excel Chart"

End Sub

Answer 1

This works for me:

Sub ExportToPPT()

    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation, ok As Boolean
    Dim PPSlide As PowerPoint.Slide, ppObj As Object, ppObj2 As Object
    
    On Error Resume Next
    Set PPApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    ok = Not PPApp Is Nothing
    If ok Then ok = PPApp.Windows.Count > 0
    
    If Not ok Then
        MsgBox "You need to have powerpoint open and an " & _
               "object selected to use this macro"
        Exit Sub
    End If
    
    Set PPPres = PPApp.ActivePresentation
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Set ppObj = PPApp.ActiveWindow.Selection.ShapeRange(1)
    
    Excel.Selection.Copy
    Application.Wait (Now + TimeValue("00:00:02"))
    
    Set ppObj2 = PPSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoTrue)(1)
    With ppObj2
        .LockAspectRatio = msoFalse
        .Left = ppObj.Left
        .Top = ppObj.Top
        .Height = ppObj.Height
        .Width = ppObj.Width
        .ZOrder msoSendToBack
    End With
    ppObj.Delete 'remove the pre-selected placeholder
End Sub