can anyone help with this macro? i tried to copy embedded picture in another sheet (i define name range for it) but it always open powerpoint again and again, until we press ctrl+alt+del and end task excel.exe and powerpoint

or anyone have good macro to copy paste excel name range to powerpoint? (assuming powerpoint is closing)

thanks for any advice

Sub CopyToPPT()
DoCopy Range("PPT")
End Sub

Sub DoCopy(r As Range)
Dim Slide, ShapeRange

On Error GoTo SetObjects
Set Slide = Presentation.Slides.Add(Presentation.Slides.Count, 12)
On Error GoTo 0
r.CopyPicture xlPrinter
Set ShapeRange = Slide.Shapes
ShapeRange.Item(1).Top = 1
ShapeRange.Item(1).Left = 1
ShapeRange.Item(1).LockAspectRatio = False
ShapeRange.Item(1).Width = Slide.Master.Width
Exit Sub
End Sub

Sub SetObjects()
Set PPT = CreateObject("Powerpoint.Application")
Set Presentation = PPT.Presentations.Add
End Sub

Sub WorkbooktoPowerPoint()

'Step 1: Declare your variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim MyRange As String
Dim MyTitle As String

'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = CreateObject("PowerPoint.Application")
Set PPPres = pp.Presentations.Add
pp.Visible = True

'Step 3: Set the ranges for your data and title
MyRange = ("PPT")

'Step 4: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets
Application.Wait (Now + TimeValue("0:00:1"))

'Step 5: Copy the range as picture
xlwksht.Range(MyRange).CopyPicture _
Appearance:=xlScreen, Format:=xlPicture

'Step 6: Count slides and add new blank slide as next available slide number
'(the number 12 represents the enumeration for a Blank Slide)
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)

'Step 7: Paste the picture and adjust its position
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 1
pp.ActiveWindow.Selection.ShapeRange.Left = 1
pp.ActiveWindow.Selection.ShapeRange.Width = 700

'Step 8: Add the title to the slide then move to next worksheet
Next xlwksht

'Step 9: Memory Cleanup
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing

End Sub