【发布时间】：2019-08-17 21:27:51
【问题描述】：
我正在使用下面的代码来遍历 excel 中的表格，其中包含命名范围和单元格的位置详细信息，例如复制到 powerpoint 演示文稿。
代码完美运行。除此之外，由于某种原因它总是随机的，代码会抛出“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
【问题讨论】：
-
我建议尝试检查剪贴板，看看它是否有可用于粘贴的对象。有关详细信息，请参阅this answer。随之而来的答案有一个重要的考虑因素。
-
是的，我已经尝试过这种方法。有时 VBA 在完成复制过程之前运行粘贴调用，导致剪贴板暂时为空，然后引发错误。 VBA 似乎在前一个完成之前跳转命令
-
然后在有限的时间内循环
DoEvents，同时检查剪贴板直到剪贴板非空？因此，您的代码既可以（安全地）退出（由您控制）超时，也可以继续粘贴。
标签： excel vba powerpoint