SOLVED

Excel charts to Powerpoint exporting using VBA

Brass Contributor

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. Have searched for a macro but none has worked for me.

If anyone can share a code that can export all the charts it would really help me save my work.

 

Regards,

Aditya 

13 Replies
best response confirmed by Aditya Jadhav (Brass Contributor)
Solution

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

Hi Kinuasa,

This code worked very well and it did wonders for me.

Thank you so much for providing me with the solution.

 

Regards,

Aditya

@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)?

@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

 

@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

 

 

@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
Works wonderfully. I really appreciate the help on this. Thank you!

@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

@kinuasaFirst of all, thank you for the useful VBA codes. I transferred my charts to my customized powerpoint template  of the company  that I work for as images, but the size of the images is larger than the template that I use. How I can customize the size of the images  ? Can you give as a code that one can change the size of the images that transfers?

Thank you in advance,

Sotiris from Athens, Greece

Me too, that's exactly what I need and am also struggling to modify the ChartsToPptAsImagecode to include the Titles! Wish I understood better how all this fits together :)

 

 

@kinuasa Hi tried running this and the message  i got was: (i already had ppt opened with no new presentation, and also tried with new presentation)

moeboe_0-1609033484745.png

 

@kinuasa Thanks for the code.

 

I wanted to understand if we can tweak the code in such a way that the ppt which is uploaded on sharepoint gets updated with graphs?

In real time the graphs will get placed in the dedicated slide without having to generate a new PPT file each time we execute the code.

 

Is it possible?

 

thanks in advance

@kinuasa would you be so kind to help me with my VBA code? The code above you have already provided works wonderfully, however for my specific needs I would need to copy each chart of in a specific pp page and also define the dimension and right place in the pp. can you help mw with this?

1 best response

Accepted Solutions
best response confirmed by Aditya Jadhav (Brass Contributor)
Solution

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

View solution in original post