VBA粘贴到Powerpoint时崩溃
我已经做了一个macros在Excel中创build一些graphics，然后打开PowerPoint，并将其粘贴到模板。 在过去几个星期里，它已经工作得很好，但是在macros中添加了一些东西（这些东西是完全独立的东西，比如刷新数据和设置filter），在将graphics粘贴到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 我从你那里了解到，它给出的错误是Shapes.PasteSpecial : Invalid request. Clipboard is empty or contains data which may not be pasted here. Shapes.PasteSpecial : Invalid request. Clipboard is empty or contains data which may not be pasted here.
问题是剪贴板没有准备好在复制操作之后立即粘贴，但需要一些时间来加载数据。 让我们给它时间：
-
添加包含此代码的小模块：
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 -
现在在复制和粘贴语句之间插入以下延迟：
Dim i as Integer For i = 1 To 6 DoEvents() Sleep 500 'milliseconds Next i
这应该给复制操作足够的时间来填充剪贴板。
如果过高或过低，可以在上面的循环中调整常数"6" 。