Jan 08 2019 04:39 AM
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
Jan 14 2019 05:01 PM
SolutionHi,
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
Jan 17 2019 04:06 AM
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
Aug 19 2019 03:28 PM
@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)?
Aug 20 2019 01:16 AM
@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
Aug 20 2019 07:50 AM
@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
Aug 21 2019 06:36 PM
@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
Aug 22 2019 09:53 AM
Sep 13 2019 10:49 AM
@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
May 16 2020 10:28 AM
@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
May 27 2020 05:56 AM
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 :)
Dec 26 2020 05:45 PM
@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)
Jan 04 2021 06:46 AM
@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
Jul 12 2021 07:01 AM
@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?
Jan 14 2019 05:01 PM
SolutionHi,
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