通过 VBA 将大量图表从 Excel 复制并粘贴到 PowerPoint

Question

The task is to loop through an Excel workbook with multiple sheets and copy all the charts contained in the workbook into a PowerPoint presentation, one chart per slide and always the same layout.

Sub PPT_Example()
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim sh As Worksheet
    Dim ch As ChartObject

    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Add
    pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9

    For Each sh In ActiveWorkbook.Sheets
        For Each ch In sh.ChartObjects
            Dim pptSlide As Slide
            Dim Title As Object
            Dim Box As Object
            Dim Txt As Object
            Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
            ch.Copy
            With pptSlide.Shapes.Paste
                .Top = Application.CentimetersToPoints(3.3)
                .Left = Application.CentimetersToPoints(0.76)
                .Width = Application.CentimetersToPoints(16)
                .Height = Application.CentimetersToPoints(10.16)
            End With
            'Insert Box
            Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
              Left:=Application.CentimetersToPoints(17.1), _
              Top:=Application.CentimetersToPoints(3.3), _
              Width:=Application.CentimetersToPoints(7.22), _
              Height:=Application.CentimetersToPoints(9.29))
            Prop_Box.Name = "Box"
            pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
            pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
            
            'Insert the text box
            Set Txt = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
              Left:=Application.CentimetersToPoints(17.1), _
              Top:=Application.CentimetersToPoints(3.3), _
              Width:=Application.CentimetersToPoints(7.22), _
              Height:=Application.CentimetersToPoints(9.29))
            Txt.Name = "Txt"
            pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
            pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
            pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
            pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
            
            'Clear the Clipboard
            Dim oData   As New DataObject 'object to use the clipboard
            oData.SetText Text:=Empty 'Clear
            oData.PutInClipboard
        Next
    Next
End Sub

The code works on my example (2 sheets, 3 charts total) but not if I apply it to the real thing, which is a workbook with 10-15 sheets and 8 charts per sheet. At some (random?) point, the code stops and gives me this error.

Run-time error:
Shapes (unknown member): Invalid request. Clipboard is empty or contains data which may not be pasted here.

I noted that the code crashed earlier, the more objects I put on the slides (which is why I left the text and the box in my example, although not strictly neccessary). Given that and the error message, I assumed the clipboard might not be cleared properly after each loop, so I put in a section to clear the clipboard but it didn't solve the issue.

Answer 1

After the chart is copied, try adding DoEvents and pausing the macro for a few seconds before pasting it into your slide. And the same thing after it's pasted into your slide.

So, for example, first add the following function to pause your code . . .

Sub PauseMacro(ByVal secs As Long)

    Dim endTime As Single
    endTime = Timer + secs
    
    Do
        DoEvents
    Loop Until Timer > endTime
    
End Sub

Then try something like this . . .

            ch.Copy
            
            DoEvents
            
            PauseMacro 5 'pause for 5 seconds
            
            With pptSlide.Shapes.Paste
                DoEvents
                PauseMacro 5 'pause for 5 seconds
                .Top = Application.CentimetersToPoints(3.3)
                .Left = Application.CentimetersToPoints(0.76)
                .Width = Application.CentimetersToPoints(16)
                .Height = Application.CentimetersToPoints(10.16)
            End With

You may find through testing that you can pause for less than 5 seconds, maybe 3 seconds.

Answer 2

My approach is to split out potentially time-consuming operations into separate functions (see "'' Call as a Function" below). When a function is called, and then has to return, it seems that Excel/VBA/the-little-green-men-running-everything make sure that whatever operation it is waits until the operation is finished (the chart is totally added to the clipboard, the clipboard contents are totally pasted, the shape is totally instantiated, etc.) before continuing.

This also means not necessarily forcing a delay during execution that might not be needed (the Do Until or Loop Until or Wait that is often suggested).

So your code might look like this (caveat: untested)

Sub PPT_Example()
    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim sh As Worksheet
    Dim ch As ChartObject

    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPres = pptApp.Presentations.Add
    pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9

    For Each sh In ActiveWorkbook.Sheets
        For Each ch In sh.ChartObjects
            Dim pptSlide As Slide
            Dim Title As Object
            Dim Box As Object
            Dim Txt As Object
            Set pptSlide = NewSlide(pptPres) '' Call as a Function
            ch.Copy
            Dim shp As PowerPoint.Shape
            Set shp = NewShape(pptSlide) '' Call as a Function
            With shp
                .Top = Application.CentimetersToPoints(3.3)
                .Left = Application.CentimetersToPoints(0.76)
                .Width = Application.CentimetersToPoints(16)
                .Height = Application.CentimetersToPoints(10.16)
            End With
        'Insert Box
        Set Box = NewBox(pptSlide) '' Call as a Function
        Prop_Box.Name = "Box"
        pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
        pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
        
        'Insert the text box
        Set Txt = NewTextBox(pptSlide) '' Call as a Function
        Txt.Name = "Txt"
        pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
        pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
        pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
        pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
        
        'Clear the Clipboard
        Dim oData   As New DataObject 'object to use the clipboard
        oData.SetText Text:=Empty 'Clear
        oData.PutInClipboard
        Next
    Next
End Sub

Function NewSlide(pptPres As PowerPoint.Presentation) As PowerPoint.Slide
    Set NewSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
End Function

Function NewShape(pptSlide As PowerPoint.Slide) As PowerPoint.Shape
    Set NewShape = pptSlide.Shapes.Paste
End Function

Function NewBox(pptSlide As PowerPoint.Slide) As Object
    Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
        Left:=Application.CentimetersToPoints(17.1), _
        Top:=Application.CentimetersToPoints(3.3), _
        Width:=Application.CentimetersToPoints(7.22), _
        Height:=Application.CentimetersToPoints(9.29))
End Function

Function NewTextBox(pptSlide As PowerPoint.Slide) As Object
    Set NewTextBox = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
        Left:=Application.CentimetersToPoints(17.1), _
        Top:=Application.CentimetersToPoints(3.3), _
        Width:=Application.CentimetersToPoints(7.22), _
        Height:=Application.CentimetersToPoints(9.29))
End Function