通過VBA將大量圖表從Excel復制并粘貼到PowerPoint

我知道已經有很多關于如何在此頁面上使用 VBA 將內容從 excel 復制到 ppt 的帖子（其中許多已經幫助了我），但我有一個相當奇怪的問題，我還沒有看到解決：

該任務相當標準：回圈瀏覽具有多張作業表的 Excel 作業簿，并將作業簿中包含的所有圖表復制到 ppt 演示文稿中，每張幻燈片一張圖表，并且始終使用相同的布局。在我用于此的代碼下方

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

如果我在我的玩具示例中使用上面的代碼（2 張，總共 3 張圖表），上面的代碼可以正常作業，但如果我將它應用到真實的東西上，那是一個有 10-15 張和每張 8 張圖表的作業簿。它在那里開始，但在某個（隨機？）點，代碼停止并給我這個錯誤訊息

運行時錯誤：形狀（未知成員）：無效請求。剪貼板為空或包含可能無法粘貼到此處的資料。

我注意到代碼更早崩潰，我在幻燈片上放置的物件越多（這就是為什么我在示例中留下文本和框的原因，盡管不是絕對必要的）。鑒于此和錯誤訊息，我認為剪貼板可能無法在每次回圈后正確清除，因此我放入了一個部分來清除剪貼板，但它并沒有解決問題。

有任何想法嗎？

干杯

uj5u.com熱心網友回復：

復制圖表后，嘗試添加 DoEvents 并暫停宏幾秒鐘，然后將其粘貼到幻燈片中。粘貼到幻燈片后也是如此。

因此，例如，首先添加以下函式來暫停您的代碼。. .

Sub PauseMacro(ByVal secs As Long)

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

然后嘗試這樣的事情。. .

            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

通過測驗你可能會發現你可以暫停不到 5 秒，也許是 3 秒。

標籤：vba 调试 微软幻灯片软件

上一篇：通過VBA宏突出顯示Word檔案中選定范圍內的特定單詞的問題

下一篇：CATIAVBA-獲取繪圖中前視圖的比例