Question

我的代码从excel文档生成4个PowerPoint文件，其中我汇总了主文件中的数据。它一个接一个地将excel表的一部分剪切并粘贴到单个幻灯片上，用适当的日期替换一些填充词，保存并关闭。

我的代码有效，但有时它会被

绊倒

运行时错误-2147188160（80048240）

粘贴错误，并不总是发生在同一个地方。补救措施总是退出我的程序并重新运行它。代码在不到10秒的时间内执行，所以这没什么大不了的，只是公平的麻烦。有时需要1或2次尝试才能使其正常工作。

关于如何避免这些烦人的运行时错误绊倒的任何建议？

Sub GeneratePowerPoints()

'For using powerpoint
Dim dummyfile As String
Dim PPT As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim MySlide As Object
Dim MyShape As Object
'Dim myPresentation As PowerPoint.Presentation

Dim j As Long, allhotels() As Variant, sourcerange As Range, sourcebook As String
Dim d As Date, e As Date, f As Date, lastmonth As String, twomonthsago As String, threemonthsago As String

'Get some month names
d = DateAdd("m", -1, Now)
e = DateAdd("m", -2, Now)
f = DateAdd("m", -3, Now)
lastmonth = Format(d, "mmmm")
twomonthsago = Format(e, "mmmm")
threemonthsago = Format(f, "mmmm")

sourcebook = "BT Strat Sheet.xlsm"
allhotels = Array("SBH", "WBOS", "WBW", "WCP")
dummyfile = "P:\BT\BT 2017\BT Strategy Meetings\2017\Hotel Strat Meeting Dummy File.pptx"

For j = 0 To 3

    Set PPT = New PowerPoint.Application
    PPT.Visible = True
    PPT.Presentations.Open Filename:=dummyfile

    'SLIDE ONE
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A2:J21")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(1).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(1).Shapes(PPT.ActivePresentation.Slides(1).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE TWO
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A73:J82")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(2).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(2).Shapes(PPT.ActivePresentation.Slides(2).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 92
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE TWO
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A85:J94")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(2).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(2).Shapes(PPT.ActivePresentation.Slides(2).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 300
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE THREE
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A24:J43")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(3).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(3).Shapes(PPT.ActivePresentation.Slides(3).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE FOUR
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A54:J58")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(4).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(4).Shapes(PPT.ActivePresentation.Slides(4).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE FOUR
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A46:J50")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(4).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(4).Shapes(PPT.ActivePresentation.Slides(4).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 380
    MyShape.Height = 500
    MyShape.Width = 650

    'SLIDE FIVE
    Set sourcerange = Workbooks(sourcebook).Worksheets(allhotels(j)).Range("A61:J70")
    sourcerange.Copy
    PPT.ActivePresentation.Slides(5).Shapes.PasteSpecial DataType:=2
    Set MyShape = PPT.ActivePresentation.Slides(5).Shapes(PPT.ActivePresentation.Slides(5).Shapes.Count)

    'Set size
    MyShape.Left = 152
    MyShape.Top = 152
    MyShape.Height = 500
    MyShape.Width = 650

    'Find and replace month placeholders
    'Straight boilerplate
    Dim sld As Slide, shp As PowerPoint.Shape, i As Long

    For Each sld In PPT.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "LastMonth", lastmonth)
                End If
            End If
        Next shp
    Next sld

    For Each sld In PPT.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "TwoMonthsAgo", twomonthsago)
                End If
            End If
        Next shp
    Next sld

    For Each sld In PPT.ActivePresentation.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame Then
                If shp.TextFrame.HasText Then
                    shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "ThreeMonthsAgo", threemonthsago)
                End If
            End If
        Next shp
    Next sld

    'Save it
    PPT.ActivePresentation.SaveAs "P:\BT\BT File Drop-off Location\" & allhotels(j) & " " & lastmonth & " Strat Meeting.pptx"

    'Close it
    PPT.ActivePresentation.Close
Next j

'Exit PowerPoint
PPT.Quit
End Sub

如何避免不一致的运行时错误-2147188160（80048240）？

0 个答案: