Question

我使用下面的代码遍历excel中的表格，该表格包含要复制到PowerPoint演示文稿的单元格id的命名范围和位置详细信息。

该代码运行完美。除此之外，由于某种原因，该代码始终是随机的，因此会引发“ Shapes.paste无效请求剪贴板为空”错误。调试无济于事，因为它总是在另一个对象或命名范围处停止。我知道VBA的操作有点挑剔，因为它在实际完成复制操作之前就开始粘贴。

我尝试了Application.Wait函数，它不是最好的解决方案，它将代码减慢了3倍。同样，do / doevents调用也无济于事。

关于如何遏制此VBA问题的任何想法？

谢谢！

 Sub MyProcedure(PPT As Object, WKSHEET As String, RangeTitle As Range, SlideNumber As Long, FTsize As Variant, FT As Variant, SetLeft As Variant, SetTop As Variant, SetHeight As Variant, SetWidth As Variant, Bool As Boolean)
    Dim shP As Object
    Dim myShape As Object
    Dim mySlide As Object
    Dim tempSize As Integer, tempFont As String
    Dim Mypath As String
    Dim Myname As String
    Dim myTitle As String
    Dim ws As Worksheet

    'Application.Calculation = xlManual
    'Application.ScreenUpdating = False

    Set ws = Worksheets(WKSHEET)

    'select the name of report
    Set shP = ws.Range(RangeTitle)

    'select the ppt sheet you wish to copy the object to
    Set mySlide = PPT.ActivePresentation.slides(SlideNumber)

    'count the number of shapes currently on the PPT
    shapeCount = mySlide.Shapes.Count
    'copy the previously selected shape
    Do
    shP.Copy
    'paste it on the PPT
     DoEvents
    mySlide.Shapes.Paste 'Special DataType:=ppPasteOLEObject, Link:=msoFalse

    'wait until the count of shapes on the PPT increases, which signals that the past operation is finished.
     '<~~ wait completion of paste operation
    Loop Until mySlide.Shapes.Count > shapeCount

    'adjust formatting of the newly copied shape: position on the sheet, font & size
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
    With myShape
        .Left = SetLeft
        .Top = SetTop
        .Width = SetWidth
        .Height = SetHeight
        .TextEffect.FontSize = FTsize
        .TextEffect.FontName = FT
        .TextEffect.FontBold = Bool

    End With
    'Application.CutCopyMode = False
    'Application.Calculation = xlAutomatic
    'Application.ScreenUpdating = True

End Sub

Sub LoopThrougMyData()

    Dim FirstRow As Integer: FirstRow = 1
    Dim LastRow As Integer: LastRow = Worksheets("Table").Range("A1").End(xlDown).Row
    Dim iRow As Long
    Dim PPT As Object

    Set PPT = CreateObject("PowerPoint.Application")
    Myname = ThisWorkbook.Name
    Mypath = ThisWorkbook.Path
    PPT.Visible = True
    PPT.Presentations.Open Filename:=Mypath & "\Actuals Review Temp.pptx"

    For iRow = FirstRow To LastRow 'loop through your table here

        With Worksheets("Table").Range("test")
            MyProcedure PPT, WKSHEET:=.Cells(iRow, "A"), RangeTitle:=.Cells(iRow, "B"), SlideNumber:=.Cells(iRow, "C"), FTsize:=.Cells(iRow, "D"), FT:=.Cells(iRow, "E"), SetLeft:=.Cells(iRow, "F"), SetTop:=.Cells(iRow, "G"), SetHeight:=.Cells(iRow, "H"), SetWidth:=.Cells(iRow, "I"), Bool:=.Cells(iRow, "J")
            'call the procedure with the data from your table
        End With

    Next iRow

End Sub

Answer 1

很有可能是剪贴板问题。这是在VBA中将信息从一个应用程序复制到另一个应用程序时的常见错误。 到目前为止，我找到的最好的解决方案是在复制和粘贴之间暂停Excel应用程序几秒钟。现在，这不能解决每个实例中的问题，但是我会说95％的时间可以修复错误。剩下的5％的时间就是从剪贴板中随机删除信息。

更改此部分：

shP.Copy

'paste it on the PPT
DoEvents
mySlide.Shapes.Paste 'Special DataType:=ppPasteOLEObject, Link:=msoFalse

与此：

'Copy the shape
 shP.Copy

'Pause the Excel Application For Two Seconds
Application.Wait Now() + #12:00:02 AM#

'Paste the object on the slide as an OLEObject
mySlide.Shapes.Paste 'Special DataType:=ppPasteOLEObject, Link:=msoFalse

VBA复制/粘贴问题-PPTX创建

1 个答案: