VBA Crashing when pasting into Powerpoint
Question
I have made a macro which creates some graphs in excel and then opens powerpoint and pastes them into a template. Over the past couple of weeks and it has been working completely fine but after adding some things into the macro (which are completely separate things like refreshing data and setting filters) it seems to be crashing when pasting the graphs into powerpoint. Anyone else had similar issues in the past? There doesn't seem to be any reason why it should be doing it at all...
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 answers
solution1
1 ACCPTED 2015-02-13 17:10:23
I learned from you that the error it gives is 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.
The problem is that clipboard is not ready for pasting immediately after calling copy operation, but it needs some time to load the data. Let's give it the time:
Add small module containing this code:
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 IfNow insert the following delay between your copy and paste statements:
Dim i as Integer For i = 1 To 6 DoEvents() Sleep 500 'milliseconds Next i
This should give copy operation enough time to populate the clipboard.
You can adjust constant "6" in the above loop if it is too high or too low.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.
Related Question
VBA Macro Crashing for When Pasting Range to Table
VBA - Keep source formatting when pasting charts from Excel to PowerPoint
ActiveX Error when pasting from excel to powerpoint via vba
When pasting into powerPoint from Excel using vba, only PasteMetafilePicture works
VBA copying and pasting charts from excel to powerpoint
"This view does not support selection" error on VBA Excel when copy-pasting and resizing charts on Powerpoint slides
VBA: Saving Excel range as image and pasting to PowerPoint vs directly pasting it into PowerPoint?
Pasting multiple shapes in a Powerpoint Slide using VBA-Excel
Run-time error in VBA on pasting from excel to powerpoint
Excel VBA 2010 issue with selecting and moving table after pasting into Powerpoint
Related Tags