Forum Discussion

Brass Contributor

Jan 08, 2019

Solved

Excel charts to Powerpoint exporting using VBA

Hi, Can anyone share a code which can be used to copy and paste all the charts from a workbook to a powerpoint presenatation. Have about 95 different charts on different sheets in the workbook. H...

excel

Macros and VBA

kinuasa
Jan 15, 2019
Hi,
please try the sample code below:

Public Sub ChartsToPpt()
Dim sht As Object
Dim cht As Excel.ChartObject
Dim appPpt As Object 'PowerPoint.Application
Dim prs As Object 'PowerPoint.Presentation

'Create New Presentation
Set appPpt = CreateObject("PowerPoint.Application")
appPpt.Visible = msoTrue
Set prs = appPpt.Presentations.Add(msoTrue)

For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, _
                       ByVal TargetPresentation As Object)
Dim sld As Object 'PowerPoint.Slide
Dim cnt As Long
Const ppLayoutBlank = 12

Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutBlank) 'Add New Slide
sld.Select
cnt = sld.Shapes.Count

PowerPointApplication.CommandBars.ExecuteMso "PasteExcelChartSourceFormatting"
Do
   DoEvents
Loop Until cnt <> sld.Shapes.Count
End Sub

-------------

Public Sub ChartsToPptAsImage()
Dim sht As Object
Dim cht As Excel.ChartObject
Dim appPpt As Object 'PowerPoint.Application
Dim prs As Object 'PowerPoint.Presentation

'Create New Presentation
Set appPpt = CreateObject("PowerPoint.Application")
appPpt.Visible = msoTrue
Set prs = appPpt.Presentations.Add(msoTrue)

For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.CopyPicture Appearance:=xlScreen, _
                            Format:=xlBitmap
            PasteChartImage prs
          Next
        Case "chart"
          sht.ChartArea.Copy
          PasteChartImage prs
      End Select
    End If
Next
End Sub

Private Sub PasteChartImage(ByVal TargetPresentation As Object)
Dim sld As Object 'PowerPoint.Slide
Const ppLayoutBlank = 12
Const ppPasteBitmap = 1

Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutBlank) 'Add New Slide
With sld.Shapes.PasteSpecial(DataType:=ppPasteBitmap, Link:=msoFalse)
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
End With
End Sub

hope this helps.
kinuasa

jstolme

Copper Contributor

Aug 19, 2019

kinuasa This is really helpful! Is there a way to get it to open a specific document instead of a new presentation?Also, is there a way to make it paste special (Use Destination Theme & Link Data) for the charts (they are made the way I want them in excel and lose that when pasted into the ppt, currently)?

kinuasa

Brass Contributor

Aug 20, 2019

jstolme please try below code:

Option Explicit

Public Sub ChartsToPpt()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
  
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Open("C:\Test\Sample.pptx")
  
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, _
                       ByVal TargetPresentation As Object)
  Dim sld As Object 'PowerPoint.Slide
  Dim cnt As Long
  Const ppLayoutBlank = 12
  Const CtrlID1 = "PasteLinkedExcelChartDestinationTheme"
  Const CtrlID2 = "PasteExcelChartSourceFormatting"
  
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutBlank)
  sld.Select
  cnt = sld.Shapes.Count
  With PowerPointApplication
    If .CommandBars.GetEnabledMso(CtrlID1) = True Then
      .CommandBars.ExecuteMso CtrlID1
    Else
      .CommandBars.ExecuteMso CtrlID2
    End If
  End With
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub

jstolme

Copper Contributor

Aug 20, 2019

kinuasaThank you! This worked great. I made a small edit to make the new slides contain a title (Const ppLayoutTitleOnly = 11). The only thing I'm still trying to do is make the slide titles match the chart titles. I thought something like this may work, but I'm not sure where it would properly go or if it's appropriate given your approach. Thoughts?

'Copy and paste chart title as the slide title in PowerPoint
        currentSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text

My current code is:

Public Sub ChartsToPpt()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
  
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Open("C:SAMPLE\PATH")
  
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs
          Next
        Case "chart"
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, _
                       ByVal TargetPresentation As Object)
  Dim sld As Object 'PowerPoint.Slide
  Dim cnt As Long
  Const ppLayoutTitleOnly = 11
  Const CtrlID1 = "PasteLinkedExcelChartDestinationTheme"
  Const CtrlID2 = "PasteExcelChartSourceFormatting"
  
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutTitleOnly)
  sld.Select
  cnt = sld.Shapes.Count
  With PowerPointApplication
    If .CommandBars.GetEnabledMso(CtrlID1) = True Then
      .CommandBars.ExecuteMso CtrlID1
    Else
      .CommandBars.ExecuteMso CtrlID2
    End If
  End With
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub

kinuasa

Brass Contributor

Aug 22, 2019

jstolme Hi,　please try below code:

Option Explicit

Public Sub ChartsToPpt()
  Dim sht As Object
  Dim cht As Excel.ChartObject
  Dim appPpt As Object 'PowerPoint.Application
  Dim prs As Object 'PowerPoint.Presentation
  Dim chtTitle As String
  
  Set appPpt = CreateObject("PowerPoint.Application")
  appPpt.Visible = msoTrue
  Set prs = appPpt.Presentations.Open("C:\Test\Sample.pptx")
  
  For Each sht In ActiveWorkbook.Sheets
    If sht.Visible = xlSheetVisible Then
      sht.Select
      Select Case LCase(TypeName(sht))
        Case "worksheet"
          For Each cht In sht.ChartObjects
            If cht.Chart.HasTitle = True Then chtTitle = cht.Chart.ChartTitle.Text
            cht.Select
            Application.CommandBars.ExecuteMso "Copy"
            PasteChart appPpt, prs, chtTitle
          Next
        Case "chart"
          If sht.HasTitle = True Then chtTitle = sht.ChartTitle.Text
          Application.CommandBars.ExecuteMso "Copy"
          PasteChart appPpt, prs, chtTitle
      End Select
    End If
  Next
End Sub

Private Sub PasteChart(ByVal PowerPointApplication As Object, _
                       ByVal TargetPresentation As Object, _
                       ByVal ChartTitle As String)
  Dim sld As Object 'PowerPoint.Slide
  Dim cnt As Long
  Const ppLayoutTitleOnly = 11
  Const CtrlID1 = "PasteLinkedExcelChartDestinationTheme"
  Const CtrlID2 = "PasteExcelChartSourceFormatting"
  
  Set sld = TargetPresentation.Slides.Add( _
    TargetPresentation.Slides.Count + 1, ppLayoutTitleOnly)
  If sld.Shapes.HasTitle = msoTrue Then sld.Shapes.Title.TextFrame.TextRange.Text = ChartTitle
  sld.Select
  cnt = sld.Shapes.Count
  With PowerPointApplication
    If .CommandBars.GetEnabledMso(CtrlID1) = True Then
      .CommandBars.ExecuteMso CtrlID1
    Else
      .CommandBars.ExecuteMso CtrlID2
    End If
  End With
  Do
   DoEvents
  Loop Until cnt <> sld.Shapes.Count
End Sub

nizwa
Copper Contributor
Sep 13, 2019
kinuasa Thank you, the code works very well. I would like to be able to paste the charts as images as well as having the chart titles as the slide titles. I could not work out how to amend the ChartsToPptAsImage macro to include the titles as well. Would you be able to assist?

Regards