excel - 复制每个工作表上的图表并分别粘贴到每张幻灯片上

Question

我的代码现在将 1 个图表粘贴到 1 张幻灯片上。如何使其将 Sheet1 上的所有图表（Sheet1 中的 2 个图表）粘贴到 Slide1，将 Sheet2 上的所有图表（Sheet2 中的 2 个图表）粘贴到 Slide2，依此类推...我尝试增加count但代码失败.

Dim ppt As PowerPoint.Application
Dim ppTPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
Dim pptCL As PowerPoint.CustomLayout
Dim pptShp As PowerPoint.Shape

Dim chtt As Chart
Dim ws As Worksheet
Dim i As Long

'Optimise execution of code
Application.ScreenUpdating = False

'Get the PowerPoint Application object:
Set ppt = CreateObject("PowerPoint.Application")
ppt.Visible = msoTrue
Set ppTPres = ppt.Presentations.Add

'Get a Custom Layout:
For Each pptCL In ppTPres.SlideMaster.CustomLayouts
    If pptCL.Name = "Title and Content" Then Exit For
Next pptCL

For Each ws In ActiveWorkbook.Worksheets
    For i = 1 To ws.ChartObjects.Count
        Set pptSld = ppTPres.Slides.AddSlide(ppTPres.Slides.Count + 1, pptCL)
        pptSld.Select

        For Each pptShp In pptSld.Shapes.Placeholders
            If pptShp.PlaceholderFormat.Type = ppPlaceholderObject Then Exit For
        Next pptShp

        Set chtt = ws.ChartObjects(i).Chart
        chtt.ChartArea.Copy
        ppt.Activate
        pptShp.Select
        ppt.Windows(1).View.Paste
    Next i
Next ws

'Optimise execution of code
Set chtt = Nothing
Set pptSld = Nothing
Application.ScreenUpdating = True

'Clear clipboard
Application.CutCopyMode = False

标签： excelvbachartscopypowerpoint