使用VBA将Excel图表复制到ppt

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

有人可以帮助我提供代码或提供一些代码来执行此过程吗？