hi,

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")
PPT.Activate
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.Paste
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")
PPT.Activate
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
xlwksht.Select
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)
PPSlide.Select

'Step 7: Paste the picture and adjust its position
PPSlide.Shapes.Paste.Select
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
pp.Activate
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing

End Sub