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

kinuasa

Brass Contributor

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

Vin_Philips
Copper Contributor
Jan 04, 2021
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
- Enri9111
  Copper Contributor
  Jul 12, 2021
  @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?
moeboe
Copper Contributor
Dec 27, 2020
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)
skosmas
Copper Contributor
May 16, 2020
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

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

Aditya Jadhav
Brass Contributor
Jan 17, 2019
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