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