VBA将同一工作表中的多个图表(每次4个)导出到一张powerpoint幻灯片中

Question

我一直在尝试将多个excel图表导出到powerpoint中，但有一个问题…我想一次将4个图表导出到一个幻灯片中。

我找到了以下代码，但需要对其进行修改，以便将4个图表导出到一张幻灯片中，而不是每张幻灯片导出一个图表。

代码如下：

谢谢!

Sub PushChartsToPPT()

    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 cht As Chart
    Dim ws As Worksheet
    Dim i As Long

     '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

     'Copy ALL charts embedded in EACH WorkSheet:
    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 cht = ws.ChartObjects(i).Chart
            cht.ChartArea.Copy
            ppt.Activate
            pptShp.Select
            ppt.Windows(1).View.Paste
        Next i
    Next ws
End Sub

Answer 1

试试这个：

For Each ws In ActiveWorkbook.Worksheets
    For i = 1 To ws.ChartObjects.Count Step 4 'your count must be a multiple of four other it wouldn't work
        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
        For j = 0 to 3 
        Set cht = ws.ChartObjects(i+j).Chart
        cht.ChartArea.Copy
        ppt.Activate
        pptShp.Select
        ppt.Windows(1).View.Paste
        Next J
    Next i