Excel VBA, error 438 when adding a new slide to PPT - vba

I'm trying to add a silde in existing powerpoint presentation for each chart in opened excel file. VBA keeps throwing errors.
In here pptApp.ActivePresentation.Add I keep getting an error that the Object does not support method
And in here ActiveChart.ChartArea.Copy that the object variable is not set.
Is is as hopeless as it appears?
Option Explicit
#Const EARLYBINDING = False
Sub CopyAndLinkAllChartsToExistingPPT()
#If EARLYBINDING Then
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
#Else
Dim pptApp As Object
Dim pptPres As Object
Dim pptSlide As Object
Const ppLayoutTitle = 1
#End If
Dim workS As Worksheet
Dim chartS As Excel.ChartObjects
Dim workS_Count As Integer
Dim chartS_Count As Integer
Dim W As Integer
Dim C As Integer
'Declaring PPT objects
Set pptApp = GetObject(, "PowerPoint.Application")
Set pptPres = pptApp.Presentations.Add(msoTrue)
Set pptSlide = pptPres.Slides.Add(1, ppLayoutTitle)
'Declaring Excel objects
Set workS = ActiveWorkbook.worksheets(1)
Set chartS = workS.ChartObjects
'Amount of worksheets and charts for the loops
workS_Count = ActiveWorkbook.worksheets.Count
chartS_Count = workS.ChartObjects.Count
'Nested loop for all the worksheets and charts
For W = 1 To workS_Count
For C = 1 To chartS_Count
pptApp.ActivePresentation.Add
pptApp.ActivePresentation.Slides.Count 1, ppLayoutTitle
pptApp.ActiveWindow.View.GotoSlide
pptApp.ActivePresentation.Slides.Count
Set pptSlide = pptApp.ActivePresentation.Slides(pptApp.ActivePresentation.Slides.Count)
chartS.Select
ActiveChart.ChartArea.Copy
'Pasting chart in PowerPoint slide with a data link
pptSlide.Shapes.PasteSpecial link:=msoTrue
Next C
Next W
' Clearing the objects
Set pptApp = Nothing
Set pptPres = Nothing
Set pptSlide = Nothing
Set workS = Nothing
Set chartS = Nothing
End Sub

I think that you got it all wrong there when you are adding slides.
You already created a presentation so you just need to add slides and paste charts right ?
What you are doing in your loop (and wrong) is adding a new presentation for each chart that you need to paste, then a slide to it.
Try to simplify it:
For W = 1 To workS_Count
For C = 1 To chartS_Count
Set pptSlide = pptPres.slides.add(pptPres.slides.count, ppLayoutTitle)
chartS(chartS_Count).Select
ActiveChart.ChartArea.Copy
'Pasting chart in PowerPoint slide with a data link
pptSlide.Shapes.PasteSpecial link:=msoTrue
Next C
Next W

Related

Select all Tables in power point slide

I am trying to create a macro which selects all the tables present in a slide in ppt using vba i tried but the macro is selecting the last table or the table created lastly
here is the code
Sub CheckCoOrdinates()
Dim pptPres As Presentation
Set pptPres = Application.ActivePresentation
Dim pptSlide As Slide
Dim pptShapes As Shape
For Each pptSlide In pptPres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.Type = msoTable Then
Dim i As Integer
For i = 1 To pptSlide.Shapes.Count
pptShapes.Select
pptShapes.Copy
Next
End If
Next
Next
how to create a macro for this
Instead of pptShapes.Select, use pptShapes.Select (False)
The default behavior of Select mimics clicking on a new shape ... the clicked shape is selected, replacing any previous selection. Adding the False parameter makes it behave more like Ctrl+clicking ... the newly selected shape is ADDED to the current selection.
That'll work on a per slide basis but you can't select shapes on multiple slides, so you're going to have to re-write your macro accordingly.
I suspect you'll be better off stepping through each slide, then through each shape on the slide and copy/pasting the tables one at a time.
Dim pptPres As Presentation
Set pptPres = Application.ActivePresentation
Dim xlApp As Object
Dim xlWorkBook As Object
Dim j As Integer
Dim r1 As String
j = 1
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("D:\Book2.xlsx", True, False)
Dim pptSlide As Slide
Dim pptShapes As Shape
For Each pptSlide In pptPres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.Type = msoTable Then
Dim i As Integer
For i = 1 To pptSlide.Shapes.Count
pptSlide.Select
pptShapes.Select 'msoFalse
pptShapes.Copy
xlWorkBook.sheets(1).Activate
r1 = "A" + CStr(j)
xlWorkBook.sheets(1).Range(r1).PasteSpecial Paste:=xlPasteValues
j = j + 20
Next
End If
Next
Next
'xlWorkBook.Close SaveChanges:=True
Set xlApp = Nothing
Set xlWorkBook = Nothing

Excel VBA - bulk chart export to ppt

I've very similar problem as described previously, but in my case I'd like to export all charts at once as chartobjects into specific placeholder of my ppt template slides.
For total export I use the following solution scraped from the web. How to paste those charts directly? Somehow abovementioned solution does not work fine for me.
I'd be grateful for any advice
Option Explicit
Sub TotalExport_chart_to_ppt()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Long
Dim ws As Worksheet
Dim oChrtObj As ChartObject
Dim nPlcHolder As Long
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
' loop through each worksheet within the active workbook
For Each ws In Worksheets
' loop through each chart object on current worksheet
For Each oChrtObj In ws.ChartObjects
' copy chart as chartobject
oChrtObj.Copy
' Add a new slide and paste in the chart
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutChart)
With PPSlide.Shapes.Paste
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With
Next oChrtObj
Next ws
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
Set ws = Nothing
Set oChrtObj = Nothing
End Sub
It may help to pastespecial and then set formats
Set PPShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
There are other types of pastespecials, so you will have to decide what you want the chart to be.

Executemso error after using it to post a chart from excel to ppt

I'm current using vba to automate the creation of a ppt report. I need to copy charts from excel and paste into ppt. I successfully used the ExecuteMso "PasteExcelChartSourceFormatting" to paste the chart in, which I need to use so I can paste while keeping the source formatting and embedding the workbook, but I keep getting an error after that when my code tries to reposition the chart in ppt.
See code:
Sub Update()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
ppApp.Activate
Set ppPres = ppApp.Presentations.Open("C:\Users\ashah\Documents\Advisory.pptx")
ppPres.Slides(1).Shapes(7).Delete
Sheet1.ChartObjects("Chart 24").Chart.ChartArea.Copy
ppPres.Slides(1).Select
DoEvents
ppApp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
ppApp.CommandBars.ReleaseFocus
DoEvents
ppPres.Slides(1).Shapes(7).Left = _
(ppPres.PageSetup.SlideWidth / 2) - (ppPres.Slides(1).Shapes(7).Width / 2)
ppPres.Slides(1).Shapes(7).Top = 77
End Sub
I get a run-time error '--2147188160 (80048240)', method 'Item' of object 'Shapes' failed. The debug highlights the last few lines of my code.
Any advice would be greatly appreciated!
I know this is a little late to the game, but I used this post to try and answer the same problem I was having. And I wanted to pay it forward when I found the solution.
Now my code is a little different because I'm creating a new slide for every chart in my excel worksheet, but I too need to keep the source formatting.
Dim PowerPointApp As Object
Dim CurrentSlide As Object
Dim PowerPointDoc As Object
Dim xChart As ChartObject
Dim wb As Workbook
Dim ws As Worksheet
Dim Chart As ChartObject
Dim Sheet As Worksheet
Dim x As Long
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Set PowerPointApp = CreateObject("Powerpoint.Application")
Set PowerPointDoc = PowerPointApp.Presentations.Add(msoTrue)
PowerPointApp.Visible = True
For Each Chart In ws.ChartObjects
PowerPointApp.ActivePresentation.Slides.Add
PowerPointApp.ActivePresentation.Slides.count + 1, 12
Set CurrentSlide = PowerPointDoc.Slides(PowerPointDoc.Slides.count)
CurrentSlide.Select
Chart.Copy
PowerPointApp.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
'**********************************
Do
DoEvents
Loop Until CurrentSlide.Shapes.count > 0
'**********************************
Next Chart
The "Do While Loop" has helped avoid this error. It does take some time for the macro to finish depending on how many charts you have.
Can you try this, slightly different method
Sub Update()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
ppApp.Activate
Set ppPres = ppApp.Presentations.Open("C:\Users\ashah\Documents\Advisory.pptx")
Set ppSlide = ppPres.Slides(1)
ppSlide.Shapes(7).Delete
Sheet1.ChartObjects(1).Chart.ChartArea.Copy
ppSlide.Shapes.Paste.Select
With ppPres.Windows(1).Selection.ShapeRange
.Left = (ppPres.PageSetup.SlideWidth / 2) - (.Width / 2)
.Top = 77
End With
End Sub
UPDATE:
I split this into two subs. Can you give this a try
Sub Update()
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Set ppApp = New PowerPoint.Application
ppApp.Visible = True
ppApp.Activate
Set ppPres = ppApp.presentations.Open("C:\Users\ashah\Documents\Advisory.pptx")
Set ppSlide = ppPres.Slides(1)
ppSlide.Shapes(7).Delete
Call CopyAndPasteChart(ppApp, ppSlide)
With ppSlide.Shapes(ppSlide.Shapes.Count)
.Left = (ppPres.PageSetup.SlideWidth / 2) - (.Width / 2)
.Top = -77
End With
ppApp.CommandBars.ReleaseFocus
End Sub
Sub CopyAndPasteChart(ppApp As PowerPoint.Application, ppSlide As PowerPoint.Slide)
Sheet1.ChartObjects(1).Chart.ChartArea.Copy
ppApp.CommandBars.ExecuteMso ("PasteExcelChartSourceFormatting")
End Sub
You could edit the CopyAndPasteChart Sub a bit more if you fancied to make it usable in more situations.

Export entire Excel workbook to PowerPoint presentation

I have an 11 page Excel workbook with pages with multiple charts on one page, just text on some pages, single charts and all types of things. And I just want each sheet to export to one slide of a PowerPoint presentation.
Here is some code I found that exports all the charts and text to one slide and that's not what I need (this is code that is used frequently I found out):
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
'Copy the chart and paste it into the PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'Set the title of the slide the same as the title of the chart
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
Next
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
Now I have some code that exports table I created programmatically but I get errors when I try to export my Excel presentation:
Sub ExportToPPT()
Dim ws As Worksheet
'Open Power Point and create a new presentation.
Set pptApp = CreateObject("Powerpoint.Application")
Set pptPres = pptApp.Presentations.Add
'Show the Power Point application.
pptApp.Visible = True
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
ExcelTableToPowerPoint (ActiveSheet.Range("A1:L5"))
Next ws
'Return the "focus" to the frist sheet.
ActiveWorkbook.Worksheets(1).Activate
'Infrom the user that the macro finished.
MsgBox "The ranges were successfully copied to the new presentation!", vbInformation, "Done"
End Sub
Got a solution to my answer, hope this helps others:
'variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim SlideCount As Long
Dim row As Long
'pp variable = Create a new powerpoint presentation
Set pp = CreateObject("PowerPoint.Application")
'Powerpoint presentation = add the object (the finished product) to the poewrpoint presentation
Set PPPres = pp.Presentations.Add
'powerpoint is now visible
pp.Visible = True
'range you pick for selection
MyRange = "A2:U41"
'For each worksheet in the active workbook select all the worksheets and wait however many seconds
For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select
Application.Wait (Now + TimeValue("0:00:1"))
'copy the picture from the range you selected
xlwksht.Range(MyRange).CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
'Slide count
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'paste the shapes
PPSlide.Shapes.Paste
pp.ActiveWindow.Selection.ShapeRange.Top = 1
pp.ActiveWindow.Selection.ShapeRange.Left = 1
pp.ActiveWindow.Selection.ShapeRange.Width = 700
Next xlwksht
pp.Activate
'Cleans it up
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing

VBA gettng data from excel

I currently have a powerpoint with a chart that was generated through an excel.
What I need to do is get the values of the chart (or the excel, doesn't matter) in order to do some animations.
The problem is that I can't seem to get my code to work.
If there is ANY easier way to do this I will be glad to hear it!
Here's my code:
Sub moveRectangle()
Dim pptChart As Chart
Dim pptcd As ChartData
Dim xlWorkbook As Object
Dim PPPres As Presentation
Dim pptShape2 As Shape
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim sld As Slide
Dim shp As Shape
Dim PPApp As PowerPoint.Application
'Look for existing instance
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Create new instance if no instance exists
Set PPApp = CreateObject("Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
Set pptShape = PPPres.Slides(1).Shapes("Rectangle 16")
Set pptShape2 = PPPres.Slides(1).Shapes("Chart 3")
Set pptChart = pptShape2.Chart
Set pptcd = pptChart.ChartData
MsgBox (pptShape2.Name)
Set wb = pptcd.Workbook
Set ws = wb.Worksheets(1)
pptShape.Left = pptShape.Left - 40
End Sub
The problem is that I'm getting the following error:
Method 'Workbook' of Object 'ChartData' failed
Any help is greately appreciated!
In order to get it working without "activating" excel (which exists full screen mode, pretty annoying), what must be done is adding
With pptChart.ChartData
...
End With
This allows you to get the same functionalities without having to "activate excel"