Я использую приведенный ниже код для итерации по таблице в 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