excel to powerpoint automation

Just getting "Report Completed" msg at last but data is not pasted in PPT Slides. Any help


Sub Create_PPT()

Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim mySlideArray As Variant
Dim myRangeArray As Variant
Dim x As Long
Dim wb As Workbook
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Dim sh4 As Worksheet
Dim sh5 As Worksheet
Dim sh6 As Worksheet


Set wb = ActiveWorkbook
Set sh1 = ThisWorkbook.Sheets("Close")
Set sh2 = ThisWorkbook.Sheets("Trend")
Set sh3 = ThisWorkbook.Sheets("Total_Cloud_Chart")
Set sh4 = ThisWorkbook.Sheets("AWS_Summary_Chart")
Set sh5 = ThisWorkbook.Sheets("Compute_Chart")
Set sh6 = ThisWorkbook.Sheets("Storage_Chart")

On Error Resume Next

Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear

If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not opened, aborting."
Exit Sub
End If

If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If

On Error GoTo 0

PowerPointApp.ActiveWindow.Panes(3).Activate

Set myPresentation = PowerPointApp.ActivePresentation

mySlideArray = Array(3, 4, 5, 6, 7, 8)

myRangeArray = Array(sh1.Range("A1:F14"), sh2.Range("A1:Q28"), sh3.Range("A1:P36"), sh4.Range("A1:AA26"), sh5.Range("A1:AA40"), sh6.Range("C1:AC28"))

For x = LBound(mySlideArray) To UBound(mySlideArray)

myRangeArray(x).Copy

On Error Resume Next

Set shp = PowerPoint.ActiveWindow.Selection.ShapeRange

On Error GoTo 0

With myPresentation.PageSetup

.SlideHeight = 5.5 * 72
.SlideWidth = 10 * 72
.FirstSlideNumber = 3

End With

Next

Application.CutCopyMode = False

myPresentation.Save

MsgBox "Report Completed"

End Sub