Automate Excel Charts to PowerPoint in 1 Click

Copying Excel Charts to PowerPoint can be quite time-consuming if there are are several charts and / or if it is a repetitive task.

The codes illustrate how to automate this process.

Sub ChartsToPresentation_MultipleSlides()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
For iCht = 1 To ActiveSheet.ChartObjects.Count
    ' copy chart as a picture
    ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
        Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' Add a new slide and paste in the chart
    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutBlank)
    PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
    With PPSlide
        ' paste and select the chart picture
        .Shapes.Paste.Select
        ' align the chart
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
        PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    End With
Next
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
Sub ChartsToPresentation_SelectedCharts()
''' COPY SELECTED EXCEL CHARTS INTO POWERPOINT
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim pptApp As PowerPoint.Application
Dim iShapeIx As Integer, iShapeCt As Integer
Dim myShape As Shape, myChart As ChartObject
Dim bCopied As Boolean
Set pptApp = GetObject(, "PowerPoint.Application")
If ActiveChart Is Nothing Then
    ''' SELECTION IS NOT A SINGLE CHART
    On Error Resume Next
    iShapeCt = Selection.ShapeRange.Count
    If Err Then
        MsgBox "Select charts and try again", vbCritical, "Nothing Selected"
        Exit Sub
    End If
    On Error GoTo 0
    For Each myShape In Selection.ShapeRange
        ''' IS SHAPE A CHART?
        On Error Resume Next
        Set myChart = ActiveSheet.ChartObjects(myShape.Name)
        If Not Err Then
            bCopied = CopyChartToPowerPoint(pptApp, myChart)
        End If
        On Error GoTo 0
    Next
Else
    ''' CHART ELEMENT OR SINGLE CHART IS SELECTED
    Set myChart = ActiveChart.Parent
    bCopied = CopyChartToPowerPoint(pptApp, myChart)
End If
Dim myPptShape As PowerPoint.Shape
Dim myScale As Single
Dim iShapesCt As Integer
''' BAIL OUT IF NO PICTURES ON SLIDE
On Error Resume Next
iShapesCt = pptApp.ActiveWindow.Selection.SlideRange.Shapes.Count
If Err Then
    MsgBox "There are no shapes on the active slide", vbCritical, "No Shapes"
    Exit Sub
End If
On Error GoTo 0
''' ASK USER FOR SCALING FACTOR
myScale = InputBox(Prompt:="Enter a scaling factor for the shapes (percent)", _
    Title:="Enter Scaling Percentage") / 100
''' LOOP THROUGH SHAPES AND RESCALE "PICTURES"
For Each myPptShape In pptApp.ActiveWindow.Selection.SlideRange.Shapes
    If myPptShape.Name Like "Picture*" Then
        With myPptShape
            .ScaleWidth myScale, msoTrue, msoScaleFromMiddle
            .ScaleHeight myScale, msoTrue, msoScaleFromMiddle
        End With
    End If
Next
Set myChart = Nothing
Set myShape = Nothing
Set myPptShape = Nothing
Set pptApp = Nothing
End Sub
Function CopyChartToPowerPoint(oPPtApp As PowerPoint.Application, _
    oChart As ChartObject)
CopyChartToPowerPoint = False
oChart.Chart.CopyPicture Appearance:=xlScreen, Format:=xlPicture, Size:=xlScreen
oPPtApp.ActiveWindow.View.Paste
CopyChartToPowerPoint = True
End Function
Sub ChartsToPresentation_OneSlide()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim ppApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Dim ppShape
Dim PresentationFileName As Variant
Dim SlideCount As Long
Dim iCht As Integer
Dim aryLeft
aryLeft = Array(100, 200, 300) '<<<<<<<< adjust to fit
' Reference existing instance of PowerPoint
Set ppApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = ppApp.ActivePresentation
ppApp.ActiveWindow.ViewType = ppViewSlide
For iCht = 1 To ActiveSheet.ChartObjects.Count
' copy chart as a picture
ActiveSheet.ChartObjects(iCht).Chart.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
' Add a new slide and paste in the chart
SlideCount = PPPres.Slides.Count
With PPPres.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex)
' paste and select the chart picture
Set ppShape = .Shapes.Paste
ppShape.Left = aryLeft(iCht - 1)
ppShape.Align msoAlignMiddles, True
End With
Next
' Clean up
Set ppShape = Nothing
Set ppSlide = Nothing
Set PPPres = Nothing
Set ppApp = Nothing
End Sub
Sub ChartsToPresentation_LateBinding()
' 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
' Make sure a chart is selected
If ActiveChart Is Nothing Then
    MsgBox "Please select a chart and try again.", vbExclamation, _
        "No Chart Selected"
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
Sub ChartsToPresentation_LateBinding_WithLink()
' 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
' Make sure a chart is selected
If ActiveChart Is Nothing Then
    MsgBox "Please select a chart and try again.", vbExclamation, _
        "No Chart Selected"
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.ChartArea.Copy
    ' 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

GitHub:
https://github.com/havishmad/excel_automate_charts_ppt

YouTube:
https://youtu.be/GpRGTySiW6Y