CODEWITHSUNDEEP
vbaexcelpowerpoint
JKo_FinanceUse
JKo_FinanceUse

Reputation: 127

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

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!

Upvotes: 0

Views: 3623

Answers (2)

JKo_FinanceUse
JKo_FinanceUse

Reputation: 127

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

Upvotes: 0

Jamie Garroch - MVP
Jamie Garroch - MVP

Reputation: 2999

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

Upvotes: 0

Related Questions