Sub ChartExporter()
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim i As Integer
If PowerPointApp Is Nothing Then _
Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
On Error GoTo 0
Application.ScreenUpdating = False
Set myPresentation = PowerPointApp.Presentations.Add
For i = 1 To ThisWorkbook.Worksheets.Count
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
Worksheets(i).ChartObjects.Select 'THIS IS HIGHLIGHTED
Selection.Copy
mySlide.Shapes.Paste
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 200
myShape.Top = 200
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
Next
End Sub
VBA debugger points to the line containing Worksheets(i).Chartobjects.Select is highlighted. However, activesheet does seem to work.
My logic is that if i=1 then select chart objects, and copy those into the newly inserted slide, and then insert new slide again with worksheet(2) and so on...
Basically, I am trying to copy and paste every chart from every worksheet into every new slide.
Related
I try to apply a powerpoint table style from vba excel but i had an issue, someone can help to try how apply a style in table object ?
My macro work fine expect the style part ....
this code go to error 400 -- execution error --> Method 'table' of the object 'Shape' has failed
Set otbl = PPT_Shape.Table
This is a sample of my code here below
Sub ExcelRangeToPowerPoint()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim sPath As String
Dim project As String
Dim otbl As TableObject
'Set Title
project = Feuil1.Cells("2", "C")
'Set the template
sPath = "C:\Users\E049XXXX\OneDrive - XXX\XXX\"
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:N34")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
'Add a slide to the Presentation
PowerPointApp.ActivePresentation.ApplyTemplate "C:\Users\E049XXXX\OneDrive - XXXX\Documents\XXXXX.thmx"
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=0 '0 = ppPasteDefault
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 66
myShape.Top = 152
'Add Title
Set myTitle = mySlide.Shapes.Title
myTitle.TextFrame.TextRange.Characters.Text = project
'Add style
Set PPT_Shape = myShape
Set otbl = PPT_Shape.Table
With otbl
.ApplyStyle "{C083E6E3-FA7D-4D7B-A595-EF9225AFEA82}", True
End With
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Ok, so I have 16 references in a dropdown list, located at C10 on my spreadsheet, this alters the information in the ranges A1:Q39, after which I want range A1:Q39 and range A41:Q69 to be copied as pictures to individual slides on a powerpoint presentation.
Sub ExcelRangeToPowerPoint()
Dim rng As Range
Dim rng2 As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Set rng = ThisWorkbook.ActiveSheet.Range("A1:Q39")
Set rng2 = ThisWorkbook.ActiveSheet.Range("A41:Q69")
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
On Error GoTo 0
Application.ScreenUpdating = False
Set myPresentation = PowerPointApp.Presentations.Add
Set mySlide = myPresentation.Slides.Add(1, 12)
Cells(10, 3) = "2018A"
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=3
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 56
myShape.Top = 52
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
Set mySlide = myPresentation.Slides.Add(1, 12)
rng2.Copy
mySlide.Shapes.PasteSpecial DataType:=3
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 56
myShape.Top = 100
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
This is what I have so far, this just gets repeated 16 times for the reference that's being altered by Cells(10, 3).
When I try to run the macro, it might work for a few of those references but I usually get a runtime error "shapes.pastespecial : Invalid request. The specified data type is unavailable" I'm, as you can tell, quite inexperienced when it comes to VBA, but I'm hoping someone might be able to shed some light on this for me? If you need any more information, please let me know. Thanks.
I want to create a macro which opens an existing powerpoint template for me, copy data from a certain sheet of excel and then paste it in a specific slide in powerpoint.
I tried googling it online and created something but it doesnt work. The macro runs but I do not see any output. Please help. Below is the code I am working on:
Sub Excelrangetopowerpoint()
Dim rng As Range
Dim Powerpointapp As PowerPoint.Application
Dim myPresentation As PowerPoint.Application
Dim DestinationPPT As String
Dim myShape As Object
Dim myslide As Object
Set rng = Worksheets("regions").Range("B1:N18")
On Error Resume Next
Set Powerpointapp = CreateObject("Powerpoint.application")
DestinationPPT = ("C:\Users\OLX-Admin\Dropbox (Corporate Finance)\Naspers Monthly Reporting\Prep for call\From teams\FY2019\OLX Group Monthly Report_Sep'18_Macro.pptx")
Powerpointapp.Presentations.Open (DestinationPPT)
If Err.Number = 429 Then
MsgBox "Powerpoint could not be found.aborting."
Exit Sub
On Error GoTo 0
Application.ScreenUpdating = False
rng.Copy
Set myslide = PowerPoint.ActivePresentation.Slides(4)
myslide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = myslide.Shapes(myslide.Shapes.Count)
myShape.Left = 152
myShape.Top = 152
Powerpointapp.Visible = True
Powerpointapp.Activate
activation.CutCopyMode = False
End If
End Sub
This should work.
There were some missing parts of your modified code.
Notice that if the presentation is already open, this code will open the existing file in "read-only" mode... (so it doesn't care if powerpoint file is already opened or not).
VBA Code
Sub Excelrangetopowerpoint()
Dim rng As Range
Dim Powerpointapp As Object
Dim myPresentation As Object
Dim DestinationPPT As String
Dim myShape As Object
Dim mySlide As Object
'Copy Range from Excel
Set rng = Worksheets("regions").Range("B1:N18")
'Create an Instance of PowerPoint
On Error Resume Next
'Set your destination path for the powerpoint presentation and open the file
Set Powerpointapp = CreateObject("Powerpoint.application")
DestinationPPT = ("C:\Test\My Powerpoint\Presentation1.pptx")
Powerpointapp.Presentations.Open (DestinationPPT)
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "Powerpoint could not be found.aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Set my current Powerpoint window as activated
Set myPresentation = Powerpointapp.ActivePresentation
'Set which slide to paste into
Set mySlide = myPresentation.Slides(4)
'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 = 152
myShape.Top = 152
'Make PowerPoint Visible and Active
Powerpointapp.Visible = True
Powerpointapp.Activate
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Source: The code is a combination of the work by Chris Newman: "Copy & Paste An Excel Range Into PowerPoint With VBA" & "Copy & Paste Multiple Excel Ranges To Separate PowerPoint Slides With VBA" but with the modification that you add a path to an already existing PowerPoint file.
you were getting that error because of the below line.
Set myslide = PowerPoint.ActivePresentation.Slides(4)
The correct code is
Set myslide = PowerPointapp.ActivePresentation.Slides(4)
I have finally been able to create this macro, which copying data from a specific range in excel and pasting it into an existing PPT.
Now I want to repeat this action for multiple slides, but instead of copy pasting this macro, again and again, is there any shorter code where I just change the range, destination slide, positioning and it creates the complete set.
Here is the existing code which is working fine:
'Macro1
Sub excelrangetopowerpoint_month()
Dim rng As Range
Dim powerpointapp As Object
Dim mypresentation As Object
Dim destinationPPT As String
Dim myshape As Object
Dim myslide As Object
Set rng = Worksheets("objectives").Range("m1")
On Error Resume Next
Set powerpointapp = CreateObject("powerpoint.application")
destinationPPT = ("C:\Users\OLX-Admin\Dropbox (Corporate Finance)\Naspers Monthly Reporting\Prep for call\From teams\FY2019\OLX Group Monthly Report_Sep'18_Macro.pptx")
powerpointapp.Presentations.Open (destinationPPT)
On Error GoTo 0
Application.ScreenUpdating = False
Set mypresentation = powerpointapp.ActivePresentation
Set myslide = mypresentation.Slides(1)
rng.Copy
myslide.Shapes.PasteSpecial DataType:=2 '2 = enhanced metafile
Set myshape = myslide.Shapes(myslide.Shapes.Count)
myshape.Left = 278
myshape.Top = 175
powerpointapp.Visible = True
powerpointapp.Activate
Application.CutCopyMode = False
End Sub
You could do it with another procedure like below. So you only have to duplicate one line for every copy to a slide.
Also note that your error handling was silent. That's a bad idea, because if an error occurs you just ignore it and you will never notice. Also the following code would not work properly. I changed that too.
Sub excelrangetopowerpoint_month()
Dim powerpointapp As Object
Set powerpointapp = CreateObject("powerpoint.application")
Dim destinationPPT As String
destinationPPT = ("C:\Users\OLX-Admin\Dropbox (Corporate Finance)\Naspers Monthly Reporting\Prep for call\From teams\FY2019\OLX Group Monthly Report_Sep'18_Macro.pptx")
On Error GoTo ERR_PPOPEN
Dim mypresentation As Object
Set mypresentation = powerpointapp.Presentations.Open(destinationPPT)
On Error GoTo 0
Application.ScreenUpdating = False
PasteToSlide mypresentation.Slides(1), Worksheets("objectives").Range("m1")
'duplicate this line for all slides/ranges
'PasteToSlide mypresentation.Slides(2), Worksheets("objectives").Range("m2")
powerpointapp.Visible = True
powerpointapp.Activate
Application.CutCopyMode = False
ERR_PPOPEN:
Application.ScreenUpdating = True 'don't forget to turn it on!
If Err.Number <> 0 Then
MsgBox "Failed to open " & destinationPPT, vbCritical
End If
End Sub
Private Sub PasteToSlide(mySlide As Object, rng As Range)
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = enhanced metafile
Dim myShape As Object
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 278
myShape.Top = 175
End Sub
I am trying to copy a specific range from excel and past it in pp as a picture. I have pieced together the following code from various online sources and continue to get a run time 91 error ( Object Variable or With block variable not set) when running PowerPointApp.WindowState = 2.
How can I fix this error, and avoid it in future?
first i successfully run
Private Sub OpenPowerpoint()
Dim PPT As PowerPoint.Application
Set PPT = New PowerPoint.Application
PPT.Visible = True
PPT.Presentations.Open Filename:="C:\Users\aofarrell\Desktop\CYB\Weekly Pack Update - Template.pptx"
PPT.ActivePresentation.Slides(2).Select
End Sub
Then I attempt to run
Private Sub CopyToPowerPoint()
Dim rng As Range
Dim PowerPointApp As Object
Dim mySlide As Object
Dim myShape As Object
'Copy Range from Excel
Set rng = ThisWorkbook.Sheets("Triggers").Range("B6:Z33")
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
PowerPointApp.WindowState = 2 'ERROR OCCURS HERE
mySlide.Shapes.PasteSpecial DataType:=0
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 20
myShape.Top = 70
myShape.Width = 675
myShape.Height = 400
'Clear The Clipboard
Application.CutCopyMode = False
Application.Wait (Now + TimeValue("00:00:01"))
End Sub
Hmm... Well, first you need to define what type of Object your PowerPointApp is. And what specific object your mySlide is. Remember also that Local variables are destroyed at the end of the Sub/Function, so you may want some Module level variables/objects instead:
Option Explicit
Private PPT As PowerPoint.Application
Private PPT_pres As PowerPoint.Presentation
Private Sub OpenPowerpoint()
Set PPT = New PowerPoint.Application
PPT.Visible = True
Set PPT_pres = PPT.Presentations.Open(FileName:="C:\Users\aofarrell\Desktop\CYB\Weekly Pack Update - Template.pptx")
PPT_pres.Slides(2).Select
End Sub
Private Sub CopyToPowerPoint()
If PPT Is Nothing Then Exit Sub
If PPT_pres Is Nothing Then Exit Sub
Dim rng As Range
Dim mySlide As Object
Dim myShape As Object
Set mySlide = PPT_pres.Slides(2)
'Copy Range from Excel
Set rng = ThisWorkbook.Sheets("Triggers").Range("B6:Z33")
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
PPT.WindowState = 2
mySlide.Shapes.PasteSpecial DataType:=0
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 20
myShape.Top = 70
myShape.Width = 675
myShape.Height = 400
'Clear The Clipboard
Application.CutCopyMode = False
Application.Wait (Now + TimeValue("00:00:01"))
End Sub
(Also: if I was copying as an Image from Excel to PowerPoint, I would usually use Range.CopyPicture xlPrinter rather than Shapes.PasteSpecial which changes the size of the image based on your screen resolution)