Копирование таблиц Excel в ppt с помощью VBA

Question

Я пытаюсь скопировать несколько сводных графиков из таблицы Excel в новый ppt.

Ниже приведен код, который я пробовал. Но в этом коде после вставки первого графика он выдает ошибку, и Power Point также падает.

Sub ClickPpt()

      'Declare the needed variables
    Dim newPP As PowerPoint.Application
    Dim currentSlide As PowerPoint.Slide
    Dim Xchart As Excel.ChartObject
     'Check if PowerPoint is active
    On Error Resume Next
    Err.Clear
    Set newPP = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    'Open PowerPoint if not active
    If newPP Is Nothing Then
        Set newPP = New PowerPoint.Application
    End If
    'Create new presentation in PowerPoint
    If newPP.Presentations.Count = 0 Then
        newPP.Presentations.Add
    End If
    'Display the PowerPoint presentation
    newPP.Visible = True
    'Locate Excel charts to paste into the new PowerPoint presentation
    For Each Xchart In ActiveSheet.ChartObjects
     'Add a new slide in PowerPoint for each Excel chart
        newPP.ActivePresentation.Slides.Add newPP.ActivePresentation.Slides.Count + 1, ppLayoutText
        newPP.ActiveWindow.View.GotoSlide newPP.ActivePresentation.Slides.Count
        Set currentSlide = newPP.ActivePresentation.Slides(newPP.ActivePresentation.Slides.Count)

    'Copy each Excel chart and paste it into PowerPoint as an Metafile image
        Xchart.Select
        'ActiveChart.ChartArea.Copy
        'currentSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
        ActiveChart.Parent.Copy
        currentSlide.Shapes.Paste.Select
    'Copy and paste chart title as the slide title in PowerPoint
        'currentSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

    'Adjust the slide position for each chart slide in PowerPoint. Note that you can adjust the values to position the chart on the slide to your liking
        newPP.ActiveWindow.Selection.ShapeRange.Left = 25
        newPP.ActiveWindow.Selection.ShapeRange.Top = 150
        currentSlide.Shapes(2).Width = 250
        currentSlide.Shapes(2).Left = 500

    Next

AppActivate ("Microsoft PowerPoint")
Set currentSlide = Nothing
Set newPP = Nothing

End Sub

Может ли кто-нибудь помочь мне с кодом или предоставить какой-нибудь код для этого процесса?