粘贴到Powerpoint时VBA崩溃

时间：2015-01-28 15:23:48

标签： excel vba excel-vba powerpoint

我创建了一个宏，它在excel中创建了一些图形，然后打开powerpoint并将它们粘贴到模板中。在过去的几周里它已经完全正常工作但是在宏中添加了一些东西（这些是完全独立的东西，比如刷新数据和设置过滤器），当将图形粘贴到powerpoint时似乎崩溃了。其他人过去有过类似的问题吗？似乎没有任何理由为什么它应该这样做...... 

Sub PowerpointPres(r)
Dim PPT As Object
Dim PPApp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim PPShape As Shape

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

PPT.Presentations.Open filename:="S:\Commercial Finance\Macros for Standard Reporting\Country Manager Presentation Macro\CM Presentation Template.pptm"

Set PPApp = CreateObject("Powerpoint.Application")
Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation

'Slide 1
Set PPSlide = PPPres.Slides(1)
PPSlide.Shapes(1).TextFrame.TextRange.Text = r & " Country Review YTD " & Year(Now())

'Slide 2
Set PPSlide = PPPres.Slides(2)
PPSlide.Shapes(1).TextFrame.TextRange.Text = r & " Country Review YTD " & Year(Now())

'Slide 3
Pivots.ChartObjects(1).Copy

i = Pivots.Range("G14").Text
j = Pivots.Range("H14").Text

Set PPSlide = PPPres.Slides(3)

With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " TCV YTD " & Year(Now()) - 1 & " and " & Year(Now()) & " - by Sector"
.Shapes(2).TextFrame.TextRange.Text = "Totals:" & Year(Now()) - 1 & ":" & i & "" & Year(Now()) & ":" & j
End With
PPApp.ActiveWindow.View.GotoSlide (3)
PPSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(3)
    .Top = 55
    .Left = 85
    .Height = 350
    .Width = 550
    With .Chart.SeriesCollection(1).Format.Fill
        .TwoColorGradient 2, 1
        .ForeColor.RGB = RGB(0, 94, 140)
        .BackColor.RGB = RGB(0, 165, 241)
        .GradientStops.Insert RGB(0, 138, 202), 0.5
    End With
    With .Chart.SeriesCollection(2).Format.Fill
        .TwoColorGradient 2, 1
        .ForeColor.RGB = RGB(85, 85, 85)
        .BackColor.RGB = RGB(125, 125, 125)
        .GradientStops.Insert RGB(150, 150, 150), 0.5
    End With
End With

Application.Wait (Now + TimeValue("00:00:05"))

'Slide 4
Pivots.ChartObjects(2).Copy

i = Pivots.Range("V14").Text
j = Pivots.Range("W14").Text

Set PPSlide = PPPres.Slides(4)

With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " TCV YTD " & Year(Now()) - 1 & " and " & Year(Now()) & " - by Type"
.Shapes(2).TextFrame.TextRange.Text = "Totals:" & Year(Now()) - 1 & ":" & i & "" & Year(Now()) & ":" & j
End With
PPApp.ActiveWindow.View.GotoSlide (4)
'PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
With PPSlide.Shapes(3)
    .Top = 55
    .Left = 85
    .Height = 350
    .Width = 550
    With .Chart.SeriesCollection(1).Format.Fill
        .TwoColorGradient 2, 1
        .ForeColor.RGB = RGB(0, 94, 140)
        .BackColor.RGB = RGB(0, 165, 241)
        .GradientStops.Insert RGB(0, 138, 202), 0.5
    End With
    With .Chart.SeriesCollection(2).Format.Fill
        .TwoColorGradient 2, 1
        .ForeColor.RGB = RGB(85, 85, 85)
        .BackColor.RGB = RGB(125, 125, 125)
        .GradientStops.Insert RGB(150, 150, 150), 0.5
    End With
End With

'Slide 5
LRow = Pivots.Range("AH8").End(xlDown).Row
Pivots.Range("AH8:AI" & LRow).Copy

Set PPSlide = PPPres.Slides(5)

PPApp.ActiveWindow.View.GotoSlide (5)
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(2)
    .Top = 70
    .Left = 50
    .Height = 400
    .Width = 200
End With

Pivots.ChartObjects(3).Copy

PPApp.ActiveWindow.View.GotoSlide (5)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " New TCV by AM YTD " & Year(Now())
End With
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(3)
    .Top = 80
    .Left = 300
    .Height = 380
    .Width = 350
End With

'Slide 6
LRow = Pivots.Range("AN8").End(xlDown).Row
Pivots.Rows("8:" & LRow).RowHeight = 20
Pivots.Range("AN8:AO" & LRow).Copy

Set PPSlide = PPPres.Slides(6)

PPApp.ActiveWindow.View.GotoSlide (6)
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(2)
    .Top = 70
    .Left = 50
    .Height = 380
    .Width = 200
End With

Pivots.ChartObjects(4).Copy

PPApp.ActiveWindow.View.GotoSlide (6)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " New TCV by Product YTD " & Year(Now())
End With
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(3)
    .Top = 80
    .Left = 300
    .Height = 380
    .Width = 350
End With

Application.Wait (Now + TimeValue("00:00:05"))

'Slide 7
LRow = Pivots.Range("AY8").End(xlDown).Row
Pivots.Range("AT1:AZ" & LRow).Copy

Set PPSlide = PPPres.Slides(7)

PPApp.ActiveWindow.View.GotoSlide (7)
'PPSlide.Shapes.PasteSpecial(DataType:=2).Select
PPApp.ActiveWindow.View.Paste
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " Top 10 TCV New Deals Signed YTD " & Year(Now())
End With

With PPSlide.Shapes(2)
    .Top = 70
    .Left = 30
    .Height = 380
    .Width = 660
End With

'Slide 9
LRow = Pivots.Range("BG1").End(xlDown).Row
Pivots.Range("BD1:BG" & LRow).Copy

Set PPSlide = PPPres.Slides(9)

PPApp.ActiveWindow.View.GotoSlide (9)
'PPSlide.Shapes.PasteSpecial(DataType:=2).Select
PPApp.ActiveWindow.View.Paste
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " IR – Top 10 Customers YTD " & Year(Now())
End With

With PPSlide.Shapes(2)
    .Top = 70
    .Left = 30
    .Height = 380
    .Width = 660
End With

Application.Wait (Now + TimeValue("00:00:05"))

'Slide 10
Pivots.ChartObjects(11).Copy

i = Pivots.Range("CZ19").Text
j = Pivots.Range("DA19").Text

Set PPSlide = PPPres.Slides(10)

With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " New IIR YTD " & Year(Now()) - 1 & " and " & Year(Now()) & " - by Sales Sector"
.Shapes(2).TextFrame.TextRange.Text = "Totals:" & Year(Now()) - 1 & ":" & i & "" & Year(Now()) & ":" & j
End With
PPApp.ActiveWindow.View.GotoSlide (10)
PPSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(3)
    .Top = 55
    .Left = 85
    .Height = 350
    .Width = 550
    With .Chart.SeriesCollection(1).Format.Fill
        .TwoColorGradient 2, 1
        .ForeColor.RGB = RGB(0, 94, 140)
        .BackColor.RGB = RGB(0, 165, 241)
        .GradientStops.Insert RGB(0, 138, 202), 0.5
    End With
    With .Chart.SeriesCollection(2).Format.Fill
        .TwoColorGradient 2, 1
        .ForeColor.RGB = RGB(85, 85, 85)
        .BackColor.RGB = RGB(125, 125, 125)
        .GradientStops.Insert RGB(150, 150, 150), 0.5
    End With
End With

'Slide 11

Pivots.ChartObjects(5).Copy

Set PPSlide = PPPres.Slides(11)

LRow = Pivots.Range("BK:BO").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row

i = Pivots.Range("BL" & LRow).Text
j = Pivots.Range("BM" & LRow).Text
k = Pivots.Range("BN" & LRow).Text
l = Pivots.Range("BO" & LRow).Text

PPApp.ActiveWindow.View.GotoSlide (11)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " Monthly Net MRC YTD " & Year(Now())
With .Shapes(2)
    .TextFrame.TextRange.Text = "MRC Won " & Year(Now()) & " YTD:         € " & i
    .Top = 5
    .Left = 475
    .Height = 30
    .Width = 250
End With

With .Shapes(3)
    .TextFrame.TextRange.Text = "MRC Ceased " & Year(Now()) & " YTD:    € " & j
    .Top = 20
    .Left = 475
    .Height = 30
    .Width = 250
End With

With .Shapes(4)
    .TextFrame.TextRange.Text = "MRC Erosion " & Year(Now()) & " YTD:    € " & k
    .Top = 35
    .Left = 475
    .Height = 30
    .Width = 250
End With

With .Shapes(5)
    .TextFrame.TextRange.Text = "Net MRC " & Year(Now()) & " YTD:           € " & l
    .Top = 50
    .Left = 475
    .Height = 30
    .Width = 250
End With

End With
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(6)
    .Top = 80
    .Left = 30
    .Height = 380
    .Width = 650
    With .Chart
        .ChartStyle = 2
        .SeriesCollection(1).Format.Fill.ForeColor.RGB = RGB(146, 208, 80)
        .SeriesCollection(2).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
        .SeriesCollection(3).Format.Fill.ForeColor.RGB = RGB(246, 139, 31)
        .SeriesCollection(4).Format.Fill.ForeColor.RGB = RGB(51, 51, 255)
    End With
End With

'Slide 12
LRow = Pivots.Range("BR1").End(xlDown).Row
Pivots.Range("BR1:BW" & LRow).Copy

Set PPSlide = PPPres.Slides(12)

PPApp.ActiveWindow.View.GotoSlide (12)
'PPSlide.Shapes.PasteSpecial(DataType:=2).Select
PPApp.ActiveWindow.View.Paste
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " Net MRC - Top 10 Customer YTD " & Year(Now())
End With

With PPSlide.Shapes(2)
    .Top = 70
    .Left = 30
    .Height = 380
    .Width = 660
End With

Application.Wait (Now + TimeValue("00:00:05"))

'Slide 13
Pivots.ChartObjects(6).Copy

Set PPSlide = PPPres.Slides(13)

PPApp.ActiveWindow.View.GotoSlide (13)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " Revenue at Risk – MRC up for renewal"
End With
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(2)
    .Top = 50
    .Left = 30
    .Height = 420
    .Width = 650
    .Chart.ChartStyle = 8
End With

'Slide 14
Pivots.ChartObjects(7).Copy

Set PPSlide = PPPres.Slides(14)

PPApp.ActiveWindow.View.GotoSlide (14)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " Revenue at Risk – Top 10 MRC up for renewal " & Year(Now())
End With
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(2)
    .Top = 50
    .Left = 30
    .Height = 420
    .Width = 650
    .Chart.ChartStyle = 8
End With

'Slide 15
Pivots.ChartObjects(8).Copy

Set PPSlide = PPPres.Slides(15)
i = Year(DateSerial(Year(Now()), Month(Now()), Day(Now())))
j = Month(DateSerial(Year(Now()), Month(Now()), Day(Now())))
PPApp.ActiveWindow.View.GotoSlide (15)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " – Top 5 MRC expiring " & Left(MonthName(j), 3) & "-" & i
End With
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(2)
    .Top = 50
    .Left = 30
    .Height = 370
    .Width = 650
    .Chart.ChartStyle = 8
End With

Application.Wait (Now + TimeValue("00:00:05"))

'Slide 16
Pivots.ChartObjects(9).Copy

Set PPSlide = PPPres.Slides(16)
i = Year(DateSerial(Year(Now()), Month(Now()) + 1, Day(Now())))
j = Month(DateSerial(Year(Now()), Month(Now()) + 1, Day(Now())))
PPApp.ActiveWindow.View.GotoSlide (16)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " – Top 5 MRC expiring " & Left(MonthName(j), 3) & "-" & i
End With
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(2)
    .Top = 50
    .Left = 30
    .Height = 370
    .Width = 650
    .Chart.ChartStyle = 8
End With

'Slide 17
Pivots.ChartObjects(10).Copy

Set PPSlide = PPPres.Slides(17)
i = Year(DateSerial(Year(Now()), Month(Now()) + 2, Day(Now())))
j = Month(DateSerial(Year(Now()), Month(Now()) + 2, Day(Now())))
PPApp.ActiveWindow.View.GotoSlide (17)
With PPSlide
.Shapes(1).TextFrame.TextRange.Text = r & " – Top 5 MRC expiring " & Left(MonthName(j), 3) & "-" & i
End With
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(2)
    .Top = 50
    .Left = 30
    .Height = 370
    .Width = 650
    .Chart.ChartStyle = 8
End With

'Slide 18
Pivots.Range("FJ1:FO11").Copy

Set PPSlide = PPPres.Slides(18)

PPApp.ActiveWindow.View.GotoSlide (18)
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(1)
    .TextFrame.TextRange.Text = r & ": SalesForce Pipeline & Top Deals"
    .Left = 100
    .Top = 10
    .Height = 50
    .Width = 650
End With

Pivots.Range("SalesForceTable2").Copy
PPApp.ActiveWindow.View.Paste

With PPSlide.Shapes(2)
    .Top = 130
    .Left = 30
    .Height = 320
    .Width = 660
End With

With PPSlide.Shapes(3)
    .Top = 70
    .Left = 30
    .Height = 50
    .Width = 660
End With

Application.Wait (Now + TimeValue("00:00:05"))

'Slide 19
LRow = Pivots.Range("EC1").End(xlDown).Row

If LRow < 19 Then
Pivots.Range("EC1:EL" & LRow).Copy
Else
Pivots.Range("EC1:EL19").Copy
End If

Set PPSlide = PPPres.Slides(19)

PPApp.ActiveWindow.View.GotoSlide (19)
'PPSlide.Shapes.PasteSpecial(DataType:=2).Select
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(1)
    .TextFrame.TextRange.Text = r & " Individual Performance YTD " & Year(Now()) & " (pg1)"
    .Left = 20
    .Top = 20
    .Height = 50
    .Width = 650
End With

With PPSlide.Shapes(2)
    .Top = 70
    .Left = 30
    .Height = 380
    .Width = 660
End With

'Slide 20
If LRow > 19 Then

Pivots.Range("EM2:EV20").ClearContents

If LRow > 19 And LRow <= 37 Then
Pivots.Range("EC20:EL" & LRow).Copy
Else
Pivots.Range("EC20:EL37").Copy
End If

Pivots.Range("EM2").PasteSpecial xlValues

LRow2 = Pivots.Range("EM1").End(xlDown).Row

Columns("EM:EV").EntireColumn.AutoFit

Pivots.Range("EM1:EV" & LRow2).Copy

Set PPLayout = PPPres.Slides(19).CustomLayout
Set PPSlide = PPPres.Slides.AddSlide(20, PPLayout)
Set PPSlide = PPPres.Slides(20)

With PPSlide
.Shapes(2).Delete
End With

PPApp.ActiveWindow.View.GotoSlide (20)
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(1)
    .TextFrame.TextRange.Font.Size = 28
    .TextFrame.TextRange.Text = r & " Individual Performance YTD " & Year(Now()) & " (pg2)"
    .Left = 20
    .Top = 20
    .Height = 50
    .Width = 650
End With

With PPSlide.Shapes(2)
    .Top = 70
    .Left = 30
    .Height = 380
    .Width = 660
End With

Else

On Error GoTo ContinueHere

For i = PPApp.Slides.Count To 20 Step -1

PPPres.Slides(i).Delete

Next

On Error GoTo 0

End If

Application.Wait (Now + TimeValue("00:00:05"))

'slide 21
If LRow > 37 Then

Pivots.Range("EM2:EV20").ClearContents

If LRow > 37 And LRow <= 55 Then
Pivots.Range("EC38:EL" & LRow).Copy
Else
Pivots.Range("EC38:EL55").Copy
End If

Pivots.Range("EM2").PasteSpecial xlValues

LRow2 = Pivots.Range("EM1").End(xlDown).Row

Columns("EM:EV").EntireColumn.AutoFit

Pivots.Range("EM1:EV" & LRow2).Copy

Set PPLayout = PPPres.Slides(19).CustomLayout
Set PPSlide = PPPres.Slides.AddSlide(21, PPLayout)
Set PPSlide = PPPres.Slides(21)

With PPSlide
.Shapes(2).Delete
End With

PPApp.ActiveWindow.View.GotoSlide (21)
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(1)
    .TextFrame.TextRange.Font.Size = 28
    .TextFrame.TextRange.Text = r & " Individual Performance YTD " & Year(Now()) & " (pg3)"
    .Left = 20
    .Top = 20
    .Height = 50
    .Width = 650
End With

With PPSlide.Shapes(2)
    .Top = 70
    .Left = 30
    .Height = 380
    .Width = 660
End With

Else

On Error GoTo ContinueHere

For i = PPApp.Slides.Count To 20 Step -1

PPPres.Slides(i).Delete

Next

On Error GoTo 0

End If

'Slide 22
If LRow > 55 Then

Pivots.Range("EM2:EV20").ClearContents

If LRow > 55 And LRow <= 73 Then
Pivots.Range("EC56:EL" & LRow).Copy
Else
Pivots.Range("EC56:EL73").Copy
End If

Pivots.Range("EM2").PasteSpecial xlValues

LRow2 = Pivots.Range("EM1").End(xlDown).Row

Columns("EM:EV").EntireColumn.AutoFit

Pivots.Range("EM1:EV" & LRow2).Copy

Set PPLayout = PPPres.Slides(19).CustomLayout
Set PPSlide = PPPres.Slides.AddSlide(22, PPLayout)
Set PPSlide = PPPres.Slides(22)

With PPSlide
.Shapes(2).Delete
End With

PPApp.ActiveWindow.View.GotoSlide (22)
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(1)
    .TextFrame.TextRange.Font.Size = 28
    .TextFrame.TextRange.Text = r & " Individual Performance YTD " & Year(Now()) & " (pg4)"
    .Left = 20
    .Top = 20
    .Height = 50
    .Width = 650
End With

With PPSlide.Shapes(2)
    .Top = 70
    .Left = 30
    .Height = 380
    .Width = 660
End With

Else

On Error GoTo ContinueHere

For i = PPApp.Slides.Count To 20 Step -1

PPPres.Slides(i).Delete

Next

On Error GoTo 0

End If

'slide 23
If LRow > 73 Then

Pivots.Range("EM2:EV20").ClearContents

If LRow > 73 And LRow <= 91 Then
Pivots.Range("EC74:EL" & LRow).Copy
Else
Pivots.Range("EC74:EL91").Copy
End If

Pivots.Range("EM2").PasteSpecial xlValues

LRow2 = Pivots.Range("EM1").End(xlDown).Row

Columns("EM:EV").EntireColumn.AutoFit

Pivots.Range("EM1:EV" & LRow2).Copy

Set PPLayout = PPPres.Slides(19).CustomLayout
Set PPSlide = PPPres.Slides.AddSlide(23, PPLayout)
Set PPSlide = PPPres.Slides(23)

With PPSlide
.Shapes(2).Delete
End With

PPApp.ActiveWindow.View.GotoSlide (23)
PPApp.ActiveWindow.View.Paste
With PPSlide.Shapes(1)
    .TextFrame.TextRange.Font.Size = 28
    .TextFrame.TextRange.Text = r & " Individual Performance YTD " & Year(Now()) & " (pg5)"
    .Left = 20
    .Top = 20
    .Height = 50
    .Width = 650
End With

With PPSlide.Shapes(2)
    .Top = 70
    .Left = 30
    .Height = 380
    .Width = 660
End With

Else

On Error GoTo ContinueHere

For i = PPApp.Slides.Count To 20 Step -1

PPPres.Slides(i).Delete

Next

On Error GoTo 0

End If

ContinueHere:

PPApp.ActivePresentation.SaveAs "S:\Commercial Finance\Macros for Standard Reporting\Country Manager Presentation Macro\Outputs\" & r & "\" & Format(Now(), "dd-MM-yyyy") & ".pptm"
PPApp.ActivePresentation.Close
PPApp.Quit

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing

End Sub

1 个答案:

答案 0 :(得分：1)

我从你那里了解到，它给出的错误是Shapes.PasteSpecial : Invalid request. Clipboard is empty or contains data which may not be pasted here.

问题是剪贴板在调用复制操作后没有准备好立即粘贴，但是需要一些时间来加载数据。让我们给它时间：

  1. 添加包含此代码的小模块：

    Option Explicit 

#If VBA7 Then 
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems 
#Else 
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems 
#End If

  2. 现在在复制和粘贴语句之间插入以下延迟：

    Dim i as Integer
For i = 1 To 6 
  DoEvents() 
  Sleep 500 'milliseconds
Next i

    3. 这应该给复制操作足够的时间来填充剪贴板。

    如果太高或太低，您可以在上面的循环中调整常量"6"。

相关问题
最新问题