Question

我将一些excel数据粘贴到powerpoint中作为图片，我遇到了一些问题。我有290个文件，我将表格粘贴到每个PP文件的幻灯片4,5和6中。昨天当我只在幻灯片6中做了一个表时，这完美地工作了。我已经复制了这个过程，现在我随机出现随机错误。有时它的文件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

将错误Excel粘贴到Powerpoint VBA

0 个答案: