VBA: Excel to Powerpoint Copy + Paste Selected Charts into Active PPT Slide - vba

I am looking to copy + paste selected charts in Excel into an active PPT slide. I have a code that creates a new workbook and pastes all charts that are within the workbook but would like to limit the command to just selected charts. Here's the code:
Option Explicit
Sub CopyChartsToPowerPoint()
'Excel Application objects declaration
Dim ws As Worksheet
Dim objChartObject As ChartObject
Dim objChart As Chart
Dim objCht As Chart
Dim lngSlideKount As Long
'Powerpoint Application objects declaration
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSld As PowerPoint.Slide
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = msoTrue
'Create a new presentation
Set pptPres = pptApp.Presentations.Add
Set pptPres = pptApp.ActivePresentation
pptApp.ActiveWindow.ViewType = ppViewSlide
lngSlideKount = 0
For Each ws In ActiveWorkbook.Worksheets
'Verify if there is a chart object to transfer
If ws.ChartObjects.Count > 0 Then
For Each objChartObject In ws.ChartObjects
Set objChart = objChartObject.Chart
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
With objChart
'Copy + paste chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
pptSld.Shapes.Paste.Select
'Coordinates will change depending on chart
With pptApp.ActiveWindow.Selection.ShapeRange
.Left = 456
.Top = 20
End With
End With
lngSlideKount = lngSlideKount + 1
Next objChartObject
End If
Next ws
' Now check CHART sheets:
For Each objCht In ActiveWorkbook.Charts
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.Add(lngSlideKount + 1, 12)
pptApp.ActiveWindow.View.GotoSlide pptSld.SlideIndex
With objCht
'Copy chart object as picture
.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
pptSld.Shapes.Paste.Select
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End With
lngSlideKount = lngSlideKount + 1
Next objCht
'
'Activate PowerPoint application
pptApp.ActiveWindow.ViewType = ppViewNormal
pptApp.Visible = True
pptApp.Activate
If lngSlideKount > 0 Then
If lngSlideKount = 1 Then
MsgBox "1 chart was copied to PowerPoint", vbOKOnly + vbInformation, "Information"
Else
MsgBox lngSlideKount & " charts were copied to PowerPoint", vbOKOnly + vbInformation, "Information"
End If
End If
End Sub
Appreciate the help everyone!

There doesn't appear to be a nice easy .IsSelected property in Excel for Charts so you need to analyse the selection as in this function which you can call from your procedure to get a collection of selected charts (testing to make sure it's not Nothing before processing each Item in the Collection):
Option Explicit
' ***********************************************************
' Purpose: Get a collection of selected chart objects.
' Inputs: None.
' Outputs: Returns a collection of selected charts.
' Author: Jamie Garroch
' Company: YOUpresent Ltd. http://youpresent.co.uk/
' ***********************************************************
Function GetSelectedCharts() As Collection
Dim oShp As Shape
Dim oChartObjects As Variant
Set oChartObjects = New Collection
' If a single chart is selected, the returned type is ChartArea
' If multiple charts are selected, the returned type is DrawingObjects
Select Case TypeName(Selection)
Case "ChartArea"
oChartObjects.Add ActiveChart
Case "DrawingObjects"
For Each oShp In Selection.ShapeRange
If oShp.Type = msoChart Then
Debug.Print oShp.Chart.Name
oChartObjects.Add oShp.Chart
End If
Next
End Select
Set GetSelectedCharts = oChartObjects
Set oChartObjects = Nothing
End Function

So here's a solution that worked for me. The macro copy + pastes selected range or chart into the active PowerPoint slide into a certain position. This reason I wanted to do this is that each quarter/month we generate reports for our clients and this helps to reduce the time required for copying + pasting and making the deck look nice. Hope this helps anyone else who make a ton of PPTs!
'Export and position into Active Powerpoint
'Prior to running macro, enable Microsoft Powerpoint Object Library in Tools - Reference
'Identifies selection as either range or chart
Sub ButtonToPresentation()
If TypeName(Selection) = "Range" Then
Call RangeToPresentation
Else
Call ChartToPresentation
End If
End Sub
Sub RangeToPresentation()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
'Error message if range is not selected
If Not TypeName(Selection) = "Range" Then
MsgBox "Please select a worksheet range and try again."
Else
'Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
'Reference active presentation
Set PPPres = PPApp.ActivePresentation
'Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
'Copy the range as a picture
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
'Paste the range
PPSlide.Shapes.Paste.Select
'Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Sub
Sub ChartToPresentation()
'Uses Late Binding to the PowerPoint Object Model
'No reference required to PowerPoint Object Library
Dim PPApp As Object 'As PowerPoint.Application
Dim PPPres As Object 'As PowerPoint.Presentation
Dim PPSlide As Object 'As PowerPoint.Slide
'Error message if chart is not selected
If ActiveChart Is Nothing Then
MsgBox "Please select a chart and try again."
Else
'Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
'Reference active presentation
Set PPPres = PPApp.ActivePresentation
'PPApp.ActiveWindow.ViewType = 1 ' 1 = ppViewSlide
'Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
'Copy chart as a picture
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, _
Format:=xlPicture
'Paste chart
PPSlide.Shapes.Paste.Select
'Align pasted chart
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Sub

Related

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.

How to paste excel data into powerpoint and still allow the user to edit data

I was wondering if there was a way of exporting/pasting an excel range into powerpoint, while still allowing the user to edit the result. The code I keep seeing on the internet pastes data from excel into powerpoint as a picture. Below is an example:
Sub export_to_ppt(ByVal sheetname As String, ByVal initialSelection As String) ', ByVal cols As Integer, ByVal rows As Integer)
Application.ScreenUpdating = False
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
'Copy Range from Excel
'Set rng = ThisWorkbook.ActiveSheet.Range("B17:D50")
'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, 12) '12 = ppLayoutBlank
'Copy Excel Range
Dim rowCount As Integer
Dim colcount As Integer
Dim i As Integer
Dim No_sheets As Integer
No_sheets = Worksheets("Control_Sheet").Range("AP2").Value + 2
For i = 3 To No_sheets
Worksheets("Control_Sheet").Activate
Worksheets("Control_Sheet").Cells(i, 42).Select
If Worksheets("Control_Sheet").Cells(i, 42).Value = sheetname Then
rowCount = Worksheets("Control_Sheet").Cells(i, 44).Value
colcount = Worksheets("Control_Sheet").Cells(i, 43).Value
GoTo resume_copy
End If
Next i
resume_copy:
Worksheets(sheetname).Activate
Worksheets(sheetname).Range(initialSelection).Select
Selection.Resize(rowCount, colcount).Select
Selection.Copy
'Paste to PowerPoint and position
Application.Wait Now + TimeValue("00:00:01")
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 1
myShape.Top = 1
myShape.Width = 950
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Replace:
mySlide.Shapes.PasteSpecial DataType:=2
With:
mySlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse, link:=msoFalse
Hope this helps,
TheSilkCode
You can, but this process was very buggy for me when running a large ppt deck. This works by using the ppt shapes position as the location of the paste. Use a template ppt slide to test, you can paste tables and graphs this way.
Dim myApp As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim myStatsSlide As PowerPoint.Slide
Set myApp = New PowerPoint.Application
Set myPres = myApp.ActivePresentation
Set myStatsSlide = myPres.Slides(1)
Dim mySheet As Worksheet
Set mySheet = ActiveSheet
'Copy table as table, not image
Dim mySumTable As Range
Set mySumTable = mySheet.Range("A1:C5")
mySumTable.Copy
myStatsSlide.Shapes.Placeholders(1).Select
myPres.Windows(1).View.Paste
'Copy Chart, as chart not image
Dim monoChart As ChartObject
'MONO CHART
monoChart.Select
ActiveChart.ChartArea.Copy
Debug.Print monoChart.Name
myStatsSlide.Shapes.Placeholders(2).Select
myPres.Windows(1).View.Paste
Debug.Print monoChart.Name

Copy Excel charts and tables to Powerpoint

I am trying to create charts and tables in excel and then copy them to slides in powerpoint all through a PowerPoint VBA macro. I have the charts and tables created but I am having an issue with copying and pasting them over. I am not familiar with the syntax to do so. Any help would be greatly appreciated as I am new to PowerPoint VBA.
Sub GenerateVisual()
Dim dlgOpen As FileDialog
Dim folder As String
Dim excelApp As Object
Dim xlWorkBook As Object
Dim xlWorkBook2 As Object
Dim PPT As Presentation
Dim Name1 As String
Dim Name2 As String
Set PPT = ActivePresentation
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = True
Set xlWorkBook = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\MarketSegmentTotals.xls")
xlWorkBook.Sheets("MarketSegmentTotals").Activate
xlWorkBook.ActiveSheet.Shapes.AddChart.Select
xlWorkBook.ActiveChart.ChartType = xlColumnClustered
xlWorkBook.ActiveChart.SetSourceData Source:=xlWorkBook.ActiveSheet.Range("MarketSegmentTotals!$A$1:$F$2")
xlWorkBook.ActiveChart.Legend.Delete
xlWorkBook.ActiveChart.SetElement (msoElementChartTitleAboveChart)
xlWorkBook.ActiveChart.SetElement (msoElementDataLabelCenter)
xlWorkBook.ActiveChart.ChartTitle.Text = "DD Ready by Market Segment"
xlWorkBook.ActiveSheet.ListObjects.Add
xlWorkBook.ActiveSheet.ChartObjects(1).Select 'My attempt to copy them over but it doesnt work
PPT.ActiveWindow.View.Paste
End Sub
This sub will get you on your way. It needs some tweaks but this can copy over a range into a PPT:
Public Sub RangeToPresentation(sheetName, NamedRange)
Dim CopyRng As Range
Set CopyRng = Sheets(sheetName).Range(NamedRange)
Dim ppApp As Object
Dim ppPres As Object
Dim PPSlide As Object
If Not TypeName(CopyRng) = "Range" Then
MsgBox "Please select a worksheet range and try again.", vbExclamation, _
"No Range Selected"
Else
Set ppApp = GetObject(, "Powerpoint.Application")
Set ppPres = ppApp.ActivePresentation
ppApp.ActiveWindow.ViewType = ppViewNormal
Dim longSlideCount As Long
' Determine how many slides are in the presentation.
longSlideCount = ppPres.Slides.Count
With ppPres
' Insert a slide at the end of the presentation
Set PPSlide = ppPres.Slides.Add(longSlideCount + 1, ppLayoutBlank)
End With
' Select the last (blank slide)
longSlideCount = ppPres.Slides.Count
ppPres.Slides(longSlideCount).Select
Set PPSlide = ppPres.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex)
CopyRng.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
' Paste the range
PPSlide.Shapes.Paste.Select
'Set the image to lock the aspect ratio
ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoTrue
'Set the image size slightly smaller than width of the PowerPoint Slide
ppApp.ActiveWindow.Selection.ShapeRange.Width = ppApp.ActivePresentation.PageSetup.SlideWidth - 10
ppApp.ActiveWindow.Selection.ShapeRange.Height = ppApp.ActivePresentation.PageSetup.SlideHeight - 10
'Shrink image if outside of slide borders
If ppApp.ActiveWindow.Selection.ShapeRange.Width > 700 Then
ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
End If
If ppApp.ActiveWindow.Selection.ShapeRange.Height > 600 Then
ppApp.ActiveWindow.Selection.ShapeRange.Height = 600
End If
' Align the pasted range
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End If
End Sub

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 Error 438 - trying to copy Excel charts to existing Ppt presentation

I'm trying to copy charts from Excel to an existing Powerpoint Template using VBA. This code returns Error 438 - Object doesn't support this property or method:
'Create a new Powerpoint session
Set pptApp = CreateObject("PowerPoint.Application")
'
pptApp.Visible = msoTrue
'Create a new presentation
Set pptPres = pptApp.Presentations.Open("....potx")
Set pptPres = pptApp.ActivePresentation
'
pptApp.ActiveWindow.ViewType = ppViewSlide
'
Current_slide = pptPres.Slides.FindBySlideID(258)
For Each ws In ActiveWorkbook.Worksheets
'Verify if there is a chart object to transfer
If ws.ChartObjects.Count > 0 Then
For Each objChartObject In ws.ChartObjects
Set objChart = objChartObject.Chart
'ppLayoutBlank = 12
Set pptSld = pptPres.Slides.FindBySlideID(Current_slide)
pptApp.ActiveWindow.View.GotoSlide (pptSld)
With objChart
'Copy chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
pptSld.Shapes.Paste.Select
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pptApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End With
Current_slide = Current_slide + 1
Next objChartObject
End If
Next ws
Add this at top of module:
Option Explicit
Then try it with these changes (aircode, mostly, but it's a start):
Dim Current_slide as Long
Dim pptSlide as PowerPoint.Slide
Dim oShRange as PowerPoint.ShapeRange
' I don't know why exactly you're using FindBySildeID
' Care to explain that?
Current_slide = pptPres.Slides.FindBySlideID(258).SlideIndex
For Each ws In ActiveWorkbook.Worksheets
'Verify if there is a chart object to transfer
' Don't really need this; if count is 0, the code within the
' For Each loop won't execute:
' If ws.ChartObjects.Count > 0 Then
For Each objChartObject In ws.ChartObjects
Set objChart = objChartObject.Chart
'ppLayoutBlank = 12
' This needs a LONG not an object, so
Set pptSld = pptPres.Slides.FindBySlideID(Current_slide)
' You don't really need to GoTo the slide in order to operate on it
' Doing so will slow things down; if you want to see it work, though,
' uncomment:
' pptApp.ActiveWindow.View.GotoSlide (pptSld)
With objChart
'Copy chart object as picture
objChart.CopyPicture xlScreen, xlBitmap, xlScreen
'Paste copied chart picture into new slide
' pptSld.Shapes.Paste.Select
Set oShRange = pptSld.Shapes.Paste
With oShRange
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With ' oShRange
End With
Current_slide = Current_slide + 1
Next objChartObject
' End If
Next ws