Copy and paste large number of charts from Excel to PowerPoint via VBA

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.