How to avoid inconsistent Run-time error -2147188160 (80048240)? - vba

My code generates 4 PowerPoint files from an excel document where I've aggregated data from my main file. One by one, it cuts and pastes a section of the excel sheet onto an individual slide, replaces some filler words with the appropriate date, saves and closes.
My code works, however it SOMETIMES gets tripped up with a
Run-time error -2147188160 (80048240)
a pasting error, which doesn't always happen in the same place. The remedy is always to exit my program and re-run it. The code executes in less than 10 seconds, so this is no big deal, just fair nuisance. Sometimes it takes 1 or 2 tries to get it to work.
Any advice on how to avoid these annoying run-time error trip ups?
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

Related

Loop through slides and shapes to duplicate tables

I want to:
Loop through all slides in the active presentation
Loop through the shapes in the slide
If it's a table and width is <410 then position it, make a duplicate and position duplicate. (I should also be checking to see if there is another table on the slide but I couldn't get that to work.)
If it's a table and width is >880 then simply position it.
Repeat until done.
The code goes into an infinite loop when duplicating and repositioning the new shape.
Sub test()
Dim sld As Slide
Dim shp As Shape
Dim sr As Series
Dim chrt As Chart
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTable Then
With shp
MsgBox .Width
If .Width < 410 Then
MsgBox "<410"
.Top = 170
.Left = 35
.Width = 409
.Duplicate
.Top = 170
.Left = 515
.Width = 409
End If
If .Width > 880 Then
MsgBox ">880"
.Top = 170
.Left = 35
.Width = 889
End If
End With
End If
Next shp
Next sld
End Sub

You want to avoid looping over sld.Shapes if you might be adding shapes to the slide within the loop.
One way to do that is to first collect the tables in a Collection and then loop over that:
Sub test()
Dim sld As Slide
Dim shp As Shape, shp2 As Shape
Dim sr As Series
Dim chrt As Chart, col As Collection
For Each sld In ActivePresentation.Slides
'first collect any existing table(s) on the slide
Set col = New Collection
For Each shp In sld.Shapes
If shp.HasTable Then col.Add shp
Next shp
'check what was found
If col.Count = 1 Then
Set shp = col(1)
If shp.Width < 410 Then
shp.Top = 170
shp.Left = 35
shp.Width = 409
Set shp2 = shp.Duplicate.Item(1) 'duplicate and get a reference to the new table
shp2.Top = 170
shp2.Left = 515
shp2.Width = 409
ElseIf shp.Width > 880 Then
shp.Top = 170
shp.Left = 35
shp.Width = 889
End If
ElseIf col.Count > 1 Then
'>1 table found - what to do here?
End If
Next sld
End Sub

Chart data label font size selection during export in VBA

Id like to be able to change the font size of the datalabels to size 14 while keeping the original text color formatting (some is white, some is black). Anyone have an idea of how I can accomplish this?
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim SldIndex As Integer
Dim Chrt As ChartObject
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
SldIndex = 1
For Each Chrt In ActiveSheet.ChartObjects
Chrt.Copy
Set PPTSlide = PPTPres.Slides.Add(SldIndex, ppLayoutBlank)
PPTSlide.Shapes.Paste
With PPTPres.Slides(SldIndex).Shapes("Chart 1")
.Top = 150
.Left = 350
.Height = 250
.Width = 350
.Chart.ChartArea.Border.LineStyle = xlContinuous
.Chart.ChartTitle.Format.TextFrame2.TextRange.Font.Size = 20
End With
SldIndex = SldIndex + 1
Next Chrt
End Sub```

how to select specific slide via VBA

I have an Excel with Macro which should:
toggle to active PPT
select slide "X" and delete graphs
Go to Tab "X" in excel
grab new Graph
Paste onto the "X" slide
repeat 5 times
here is the code I've compiled so far:
Dim PPT As Object
Dim rng As Object
Dim rng1 As Object
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim ActivePresentation As Object
'Copy Range from Excel
Set rng = Sheet3.ChartObjects("Chart 6")
Set rng1 = Sheet3.ChartObjects("Chart 7")
Set rng2 = Sheet3.ChartObjects("Chart 8")
Set PPT = CreateObject("PowerPoint.Application")
With PPT
.Visible = True
.WindowState = 1
.Activate
End With
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Set myPresentation = PowerPointApp.Presentations.Add *this should not say add as it adds a slide,but no luck with any other commands*
' PowerPointApp.Presentations.Add
Set mySlide = myPresentation.Slides.Add(1, 11) *this should not say add as it adds a slide,but no luck with any other commands*
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 20
myShape.Top = 152
rng1.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 486
myShape.Top = 152
Set mySlide = myPresentation.Slides.Add(2, 11) '11 = ppLayoutTitleOnly
etc..
End Sub
this creates a new PPT and add slides to the new ppt, have tried a numerous helps and web pages but unfortunately was not able to find a piece of code which would tackle this problem. Would be much appreciated if you could advise or point me to the correct help or tutorial which would be possible to solve this issue with.

code is based on the following assumptions from your statement
Already have a presentation open
want to copy two or three charts from each sheets, starting from Sheets(2) to Sheets(5) to slides 2 to 5 respectively as shown below.
Code may be modified to your requirement
Sub AddtoOpenPPT()
Dim PPT As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShape As PowerPoint.Shape
Dim Fname As String
Dim sld As Long, i As Long, ObjNo As Long
Dim Rng(0 To 9) As Object
Set Rng(0) = Sheet3.ChartObjects("Chart 6")
Set Rng(1) = Sheet3.ChartObjects("Chart 7")
Set Rng(2) = Sheet3.ChartObjects("Chart 8")
Set Rng(3) = Sheet3.ChartObjects("Chart 5")
Set Rng(4) = Sheet1.Range("b4:j14")
Set Rng(5) = Sheet1.Range("A4:l4", "A15:j19")
Set Rng(6) = Sheet4.ChartObjects("Chart 13")
Set Rng(7) = Sheet4.ChartObjects("Chart 15")
Set Rng(8) = Sheet4.ChartObjects("Chart 17")
Set Rng(9) = Sheet4.ChartObjects("Chart 19")
Set PPT = GetObject(class:="PowerPoint.Application")
Set myPresentation = PPT.ActivePresentation
ObjNo = 0
For sld = 2 To 5
Set mySlide = myPresentation.Slides(sld)
For i = mySlide.Shapes.Count To 1 Step -1
mySlide.Shapes(i).Delete
Next
For i = 1 To 3
Rng(ObjNo).Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = IIf(i Mod 2 = 1, 20, 486)
myShape.Top = IIf(i < 3, 50, 200)
ObjNo = ObjNo + 1
If ObjNo > UBound(Rng) Then Exit For
Next
If ObjNo > UBound(Rng) Then Exit For
Next sld
End Sub

VBA - Export excel charts to power point on same slide

Sub Export_Allcahrts_ppt()
Dim mypowerpoint As PowerPoint.Application
Set mypowerpoint = New PowerPoint.Application
mypowerpoint.Visible = msoTrue
Dim mypowerpoint_pres As PowerPoint.Presentation
Set mypowerpoint_pres = mypowerpoint.Presentations.Add
Dim myslide As PowerPoint.Slide
Set myslide = mypowerpoint_pres.Slides.Add(1, ppLayoutBlank)
Dim mychart As ChartObject
Dim j As Long
j = 0
For Each mychart In Sheet1.ChartObjects
j = j + 1
Next
For Each mychart In Sheet1.ChartObjects
mychart.Copy
myslide.Shapes.PasteSpecial ppPasteBitmap
myslide.Shapes(1).Top = 100
myslide.Shapes(1).Height = 200
myslide.Shapes(1).Left = 30
If mypowerpoint_pres.Slides.Count < j Then
Set myslide = mypowerpoint_pres.Slides.Add(mypowerpoint_pres.Slides.Count + 1, ppLayoutBlank)
Else
Exit Sub
End If
Next
End Sub

First, you don't need to loop to get j; just use
j = Sheet1.ChartObjects.Count
But you also don't need j at all. What your code does is insert a new slide for each new chart if the number of slides does not yet equal the number of charts copied so far.
So try this slightly rearranged and streamlined code. I haven't tested it, but I don't think I've changed the syntax.
Sub Export_Allcahrts_ppt()
Dim mypowerpoint As PowerPoint.Application
Dim mypowerpoint_pres As PowerPoint.Presentation
Dim myslide As PowerPoint.Slide
Dim mychart As ChartObject
Dim j As Long
Set mypowerpoint = New PowerPoint.Application
mypowerpoint.Visible = msoTrue
Set mypowerpoint_pres = mypowerpoint.Presentations.Add
Set myslide = mypowerpoint_pres.Slides.Add(1, ppLayoutBlank)
j = Sheet1.ChartObjects.Count
For Each mychart In Sheet1.ChartObjects
mychart.Copy
myslide.Shapes.PasteSpecial ppPasteBitmap
With myslide.Shapes(myslide.Shapes.Count)
.Top = 100
.Height = 200
.Left = 30
End With
Next
End Sub

VBA do not copy range to .ppt

I want VBA to paste all the Worksheets into example PPT, which started from particular slide, for example slide NUM.3
However the code which is in use right now, do not paste the selected area into PPT file. Could you help me?
Here is my code:
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
Set rng = ThisWorkbook.ActiveSheet.Range("A1:Z100")
' Set mySlide = myPresentation.Slides.Add(myPresentation.Slides.Count + 1, 12)
' SlideNumb = myPresentation.Slides.Count
Set mySlide = myPresentation.Slides(SlideNumb).Select '(myPresentation.Slides.Count + 1, 12) '(myPresentation.Slides.Count + 1, 12)
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.LockAspectRatio = msoFalse
myShape.Left = 36.72
myShape.Top = 112.32
myShape.Width = 854.64
myShape.Height = 397.44
Application.CutCopyMode = False
ShtNum = ShtNum + 1
SlideNumb = SlideNumb + 1
Next ws

Change this:
Set mySlide = myPresentation.Slides(SlideNumb).Select
To this:
Set mySlide = myPresentation.Slides(SlideNumb)
Delete this:
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.LockAspectRatio = msoFalse
myShape.Left = 36.72
myShape.Top = 112.32
myShape.Width = 854.64
myShape.Height = 397.44
remove the comments and give it a try again.