Option Explicit
 
 
 
Function getPPPres() As PowerPoint.Presentation
 
    Dim PPApp As PowerPoint.Application
 
 
 
    '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 getPPPres = PPApp.ActivePresentation
 
    Else
 
        'There are no presentations

        'Create New Presentation

        Set getPPPres = PPApp.Presentations.Add
 
    End If
 
    Set PPApp = Nothing
 
End Function
 
 
 
Function getNewSlide(PPPres As PowerPoint.Presentation) As PowerPoint.Slide
 
    Set getNewSlide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutBlank)
 
End Function
 
 
 
Sub ExportChartsToPPT(wksChartsFromSheet As Worksheet)
 
    Dim PPPres          As PowerPoint.Presentation
 
    Dim PPSlide         As PowerPoint.Slide
 
    Dim cht             As ChartObject
 
 
 
    If wksChartsFromSheet.ChartObjects.Count = 0 Then
 
        MsgBox "No Chart to Export to Powerpoint", vbInformation, ""
 
        Exit Sub
 
    End If
 
 
 
    Set PPPres = getPPPres
 
 
 
'    If PPPres.Slides.Count = 0 Then

'        Set PPSlide = getNewSlide(PPPres)

'    End If

 
 
    For Each cht In wksChartsFromSheet.ChartObjects
 
        Set PPSlide = getNewSlide(PPPres)
 
        cht.CopyPicture
 
        PPSlide.Select
 
        PPSlide.Shapes.Paste.Select
 
        PPSlide.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
 
        PPSlide.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
 
        PPSlide.Select
 
    Next cht
 
 
 
    Set cht = Nothing
 
    Set PPSlide = Nothing
 
    Set PPPres = Nothing
 
End Sub
 
 
 
Sub TestExecute()
 
    Call ExportChartsToPPT(Sheet2)
 
End Sub