Macro excel a powerpoint

[chunos22]

Hola gente tengo un problema con esta macro, lo que quiero hacer es que los gráficos que tengo en excel se copien en un PowerPontl ya activo, y estos gráficos se vayan copiando en cada diapositiva diferente..... Luego de esta linea de código ( PPSlide.Shapes.Paste ) debería hacer algo para que vaya iterando las diapositivas, pero todo lo que pruebo me tira error,. ayuda por favor ...

Sub ExcelToExistingPowerPoint()

Dim PPApp As PowerPoint.Application

Dim PPPres As PowerPoint.Presentation

Dim PPSlide As PowerPoint.Slide

' Reference instance of PowerPoint

On Error Resume Next

' Check whether PowerPoint is running

Set PPApp = GetObject(, "PowerPoint.Application")

If PPApp Is Nothing Then

' PowerPoint is not running, create new instance

Set PPApp = CreateObject("PowerPoint.Application")

' For automation to work, PowerPoint must be visible

PPApp.Visible = True

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)

Else

' There are no presentations

' Create new presentation

Set PPPres = PPApp.Presentations.Add

' Add first slide

Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)

End If

On Error GoTo 0

' Some PowerPoint actions work best in normal slide view

PPApp.ActiveWindow.ViewType = ppViewSlide

''---------------------

'' Do Some Stuff Here

''---------------------

'Recorrer tods los gráficos en nuestro libro de Excel

For Each hoja In ThisWorkbook.Worksheets

For Each grafico In hoja.ChartObjects

'Copiar gráfico en la dispositiva

hoja.ChartObjects(grafico.Index).Chart.CopyPicture

PPSlide.Shapes.Paste

'Centramos la imagen insertada

' PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue

' PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue

Next

Next

' Clean up

Set PPSlide = Nothing

Set PPPres = Nothing

Set PPApp = Nothing

End Sub