Copy from Excel Worksheets to specific Powerpoint slides - vba

Question

I am transferring data from excel to powerpoint slides with an automated script by using EXcel VBA. I'm trying to copy the usedrange of a excel worksheet and paste it to as a image in a powerpoint Template of 4th slide and from there on it should add new slides and copy the remaining worksheets to the next further slides.
So, In my code for the first iteration it is copying from excel worksheet of first sheet and pasting it in the 4th slide but for the next iteration it is throwing the error as below:
The code which i'm currently using is getting the following error
"Run Time Error -2147188160(80048240) AutomationError".
I'm new to Excel VBA. Please help
Can anyone suggest me the code for the following.
Hope this is clearly explained. If not please ask for more clarification.
Thanks
Private Sub CommandButton2_Click()
Dim PP As PowerPoint.Application
Dim PPpres As Object
Dim PPslide As Object
Dim PpTextbox As PowerPoint.Shape
Dim SlideTitle As String
Dim SlideNum As Integer
Dim WSrow As Long
Dim Sh As Shape
Dim Rng As Range
Dim myshape As Object
Dim myobject As Object
'Open PowerPoint and create new presentation
Set PP = GetObject(class, "PowerPoint.Application")
PP.Visible = True
Set PPpres = PP.Presentations.Open("\\C:\Users\Templates")
'Specify the chart to copy and copy it
For Each WS In Worksheets
If (WS.Name) <> "EOS" Then
ThisWorkbook.Worksheets(WS.Name).Activate
ThisWorkbook.ActiveSheet.UsedRange.CopyPicture
lastrow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
'Copy Range from Excel
Set Rng = ThisWorkbook.ActiveSheet.Range("A1:I" & lastrow)
'Copy Excel Range
Rng.Copy
For k = 4 To 40
slidecount = PPpres.Slides.Count
PP.ActiveWindow.View.GotoSlide (k)
'Paste to PowerPoint and position
Set PPslide = PPpres.Slides(k)
PPslide.Shapes.PasteSpecial DataType:=10 '2 = ppPasteEnhancedMetafile
Set myshape = PPslide.Shapes(PPslide.Shapes.Count)
'Set position:
myshape.Left = 38
myshape.Top = 152
'Add the title to the slide
SlideTitle = "Out of Support, " & WS.Name & " "
Set PpTextbox = PPslide.Shapes.AddTextbox(msoTextOrientationHorizontal,
0, 20, PPpres.PageSetup.SlideWidth, 60)
PPslide.Shapes(1).TextFrame.TextRange = SlideTitle
'Set PPslide = PPpres.Slides.Add(slidecount + 1, ppLayoutTitle)
'Make PowerPoint Visible and Active
PP.Visible = True
PP.Activate
'Clear The Clipboard
Application.CutCopyMode = False
Next k
Exit For
End If
Next WS
End Sub