將錯誤 Excel 粘貼到 Powerpoint VBA

Question

我將一些 excel 數據作為圖片粘貼到 powerpoint 中，但我遇到了一些問題。 我有 290 個文件，我將表格粘貼到每個 PP 文件的幻燈片 4、5 和 6 中。 昨天，當我在幻燈片 6 中只做 1 個表格時，這非常有效。我已經復制了這個過程，現在我在隨機時間不斷收到隨機錯誤。 有時它的文件 10，其他文件 50，每次都不一樣。 粘貼數據類型的錯誤范圍不可用或剪貼板為空。 我已經嘗試了每種數據類型，粘貼為元文件、形狀、圖片，只是基本粘貼，沒有什么能阻止錯誤。 我不知道！ 這是我的代碼：請幫助！

Sub Update_Site_Report()

'Initiate Variables
Dim objPPT As Object
Dim PPTPrez As Object
Dim FinSlide As Object
Dim AssumSlide As Object
Dim RiskSlide As Object
Dim FinTable As Object
Dim AssumTable As Object
Dim RiskTable As Object
Dim fileNameString As String
Dim PicCount As Long
Dim PicCount1 As Long
Dim PicCount2 As Long
Dim i As Long
Dim fileN As String
Dim Directory As String


'Create and open powerpoint application

Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True

Application.ScreenUpdating = False

'Update site report table from spreadsheet

For i = 2 To 291
    Sheet20.Cells(18, 2) = Sheet20.Cells(5, i)
    Sheet20.Cells(19, 2) = Sheet20.Cells(6, i)
    Sheet20.Cells(20, 2) = Sheet20.Cells(7, i)
    Sheet20.Cells(21, 2) = Sheet20.Cells(8, i)
    Sheet20.Cells(18, 3) = Sheet20.Cells(10, i)
    Sheet20.Cells(19, 3) = Sheet20.Cells(11, i)
    Sheet20.Cells(20, 3) = Sheet20.Cells(12, i)
    Sheet20.Cells(21, 3) = Sheet20.Cells(13, i)

'Take column header from spreadsheet and set as filename

fileN = Sheet20.Cells(4, i)

' Allow directory to be set in excel tab

Directory = Sheet20.Cells(18, 5)


'Open powerpoint presentation at Directory with Filename

Set PPTPrez = objPPT.Presentations.Open(Directory & fileN & ".pptx")

'Set range for site report table

Set Financials = Sheet20.Range("A17:C21")
Set Assumptions = Sheet45.Range("A1:C7")
Set Risks = Sheet45.Range("A24:D41")

'Choose which slide to paste site report table

Set FinSlide = PPTPrez.Slides(6)
Set AssumSlide = PPTPrez.Slides(4)
Set RiskSlide = PPTPrez.Slides(5)

'If there is a table in powerpoint slide, delete the table

For PicCount1 = AssumSlide.Shapes.Count To 1 Step -1
    If AssumSlide.Shapes(PicCount1).Type = msoPicture Then
        AssumSlide.Shapes(PicCount1).Delete
    End If
Next

For PicCount = FinSlide.Shapes.Count To 1 Step -1
    If FinSlide.Shapes(PicCount).Type = msoPicture Then
        FinSlide.Shapes(PicCount).Delete
    End If
Next

For PicCount2 = RiskSlide.Shapes.Count To 1 Step -1
    If RiskSlide.Shapes(PicCount2).Type = msoPicture Then
        RiskSlide.Shapes(PicCount2).Delete
        Debug.Print
    End If
Next

'Paste the site report table into the site report

Financials.Copy
FinSlide.Shapes.PasteSpecial ppPasteShape
Set FinTable = FinSlide.Shapes(FinSlide.Shapes.Count)

Assumptions.Copy
AssumSlide.Shapes.PasteSpecial ppPasteShape
Set AssumTable = AssumSlide.Shapes(AssumSlide.Shapes.Count)

Risks.Copy
RiskSlide.Shapes.PasteSpecial ppPasteShape
Set RiskTable = RiskSlide.Shapes(RiskSlide.Shapes.Count)

'Set position of site report table in powerpoint

FinTable.Left = 36
FinTable.Top = 175
FinTable.Width = 614

AssumTable.Left = 36
AssumTable.Top = 80.8

RiskTable.Left = 36
RiskTable.Top = 80.8
RiskTable.Width = 641.5


'Set filename as string

fileNameString = Directory & fileN & ".pptx"

'Save file as filename

PPTPrez.SaveAs fileNameString

'Close powerpoint presentation

PPTPrez.Close

'Repeat for every site (column) - increment i

Next i

'quit powerpoint

objPPT.Quit

Application.ScreenUpdating = True

MsgBox ("Update complete, click ok to exit powerpoint")

End Sub

Answer 1

禁用 Windows 剪貼板歷史可解決此問題。