VBA粘贴Excel活动工作表中的每一嵌入式图表到一个新的幻灯片中并使用图表标题作为幻灯片标题

Sub ChartsAndTitlesToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
Dim sTitle As String

' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide

For iCht = 1 To ActiveSheet.ChartObjects.Count
    With ActiveSheet.ChartObjects(iCht).Chart
        
        ' get chart title
        If .HasTitle Then
            sTitle = .ChartTitle.Text
        Else
            sTitle = ""
        End If
        
        ' remove title (or it will be redundant)
        .HasTitle = False
        
        ' copy chart as a picture
        .CopyPicture _
            Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
        
        ' restore title
        If Len(sTitle) > 0 Then
            .HasTitle = True
            .ChartTitle.Text = sTitle
        End If
    End With
    
    ' Add a new slide and paste in the chart
    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
    PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
    With PPSlide
        ' paste and select the chart picture
        .Shapes.Paste.Select
        ' align the chart
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
        .Shapes.Placeholders(1).TextFrame.TextRange.Text = sTitle
    End With

Next

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

End Sub