Copy/Paste Excel Range/Chart into Powerpoint VBA

[Admin]

Hi All,

Here is a routine which helps you to copy paste a range or chart into power point.

Copy the entire code and paste into a new Standard module.

Public Enum PasteFormat
    xl_Link = 0
    xl_HTML = 1
    xl_Bitmap = 2
End Enum

Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByVal ObjectSheet As Worksheet, _
                                    ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)
    
    '   Modified version of code originally posted here:
    '       http://www.vbaexpress.com/kb/getarticle.php?kb_id=370
    
    '   Modified by     : Krishnakumar @ ExcelFox.com
    '   Used Late binding so that no issues when users have multiple Excel version
    
    Dim PasteRange      As Boolean
    Dim objChart        As ChartObject
    Dim lngSU           As Long
    
    Select Case TypeName(PasteObject)
        Case "Range"
            If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
            PasteRange = True
        Case "Chart": Set objChart = PasteObject.Parent
        Case "ChartObject": Set objChart = PasteObject
        Case Else
            MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
            Exit Sub
    End Select
    
    With Application
        lngSU = .ScreenUpdating
        .ScreenUpdating = 0
    End With
    
    ppApp.ActiveWindow.View.GotoSlide ppSlide.slidenumber
    
    On Error GoTo -1: On Error GoTo 0
    DoEvents
    
    If PasteRange Then
        If Paste_Type = xl_Bitmap Then
            '//Paste Range as Picture
            PasteObject.CopyPicture Appearance:=1, Format:=-4147
            ppSlide.Shapes.Paste.Select
        ElseIf Paste_Type = xl_HTML Then
            '//Paste Range as HTML
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(8, link:=1).Select  'ppPasteHTML
        ElseIf Paste_Type = xl_Link Then
            '//Paste Range as Linked
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(0, link:=1).Select   'ppPasteDefault
        End If
    Else
        If Paste_Type = xl_Link Then
            '//Copy & Paste Chart Linked
            objChart.Chart.ChartArea.Copy
            ppSlide.Shapes.PasteSpecial(link:=True).Select
        Else
            '//Copy & Paste Chart Not Linked
            objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
            ppSlide.Shapes.Paste.Select
        End If
    End If
     
    '//Center pasted object in the slide
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = lngSU
    End With
    
    AppActivate ("Microsoft Excel")
    
End Sub

An example sub to call the routine

Sub kTest()
    
    Dim ppApp       As Object
    Dim ppSlide     As Object
    
    On Error Resume Next
    Set ppApp = GetObject(, "Powerpoint.Application")
    On Error GoTo 0
    
    If ppApp Is Nothing Then
        Set ppApp = CreateObject("Powerpoint.Application")
        ppApp.Visible = True
        ppApp.presentations.Add 
    End If
    
    If ppApp.ActivePresentation.Slides.Count = 0 Then
        Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
    Else
        ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
        Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
    End If
    
    '//or you could specify the slide number. e.g. for the second slide
    'Set ppSlide = ppApp.ActivePresentation.Slides(2)
    
    Copy_Paste_to_PowerPoint ppApp, ppSlide, Sheet1, Sheet1.ChartObjects(1).Chart, xl_Bitmap
    
    '//Range
    
    'Copy_Paste_to_PowerPoint ppApp, ppSlide, Sheet1, Sheet1.Range("A1:J6"), xl_Bitmap
    
End Sub

[LalitPandey87]

Revised routine, with excel image adjustment in powerpoint slide.

Public Enum PasteFormat
    xl_Link = 0
    xl_HTML = 1
    xl_Bitmap = 2
End Enum

Sub Copy_Paste_to_PowerPoint(ByRef ppApp As Object, ByRef ppSlide As Object, ByRef PasteObject As Object, Optional ByVal Paste_Type As PasteFormat)

    '   Modified by     : LalitMohan @ ExcelFox.com


    Dim PasteRange      As Boolean
    Dim objChart        As ChartObject


    Select Case TypeName(PasteObject)
        Case "Range"
            If Not TypeName(Selection) = "Range" Then Application.Goto PasteObject.Cells(1)
            PasteRange = True
        Case "Chart": Set objChart = PasteObject.Parent
        Case "ChartObject": Set objChart = PasteObject
        Case Else
            MsgBox PasteObject.Name & " is not a valid object to paste. Macro will exit", vbCritical
            Exit Sub
    End Select
    
    ppApp.ActiveWindow.View.GotoSlide ppSlide.slidenumber
    
    On Error GoTo -1: On Error GoTo 0
    DoEvents
    
    If PasteRange Then
        If Paste_Type = xl_Bitmap Then
            '//Paste Range as Picture
            PasteObject.CopyPicture Appearance:=1, Format:=-4147
            ppSlide.Shapes.Paste.Select
        ElseIf Paste_Type = xl_HTML Then
            '//Paste Range as HTML
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(8, link:=1).Select  'ppPasteHTML
        ElseIf Paste_Type = xl_Link Then
            '//Paste Range as Linked
            PasteObject.Copy
            ppSlide.Shapes.PasteSpecial(0, link:=1).Select   'ppPasteDefault
        End If
    Else
        If Paste_Type = xl_Link Then
            '//Copy & Paste Chart Linked
            objChart.Chart.ChartArea.Copy
            ppSlide.Shapes.PasteSpecial(link:=True).Select
        Else
            '//Copy & Paste Chart Not Linked
            objChart.Chart.CopyPicture Appearance:=1, Size:=1, Format:=2
            ppSlide.Shapes.Paste.Select
        End If
    End If
     
    '//Center pasted object in the slide
    With ppApp.ActiveWindow.Selection.ShapeRange
        .LockAspectRatio = False
        .Height = ppSlide.Parent.PageSetup.SlideHeight * 0.98
        .LockAspectRatio = False
        .Width = ppSlide.Parent.PageSetup.SlideWidth * 0.98
        .Align msoAlignCenters, True
        .Align msoAlignMiddles, True
    End With
    
    Call AppActivate("Microsoft Excel")
    
    PasteRange = Empty
    Set objChart = Nothing
    
End Sub

Example sub to call this routine

Sub LalitTest()
    
    Dim ppApp       As Object
    Dim ppSlide     As Object
    
    Application.ScreenUpdating = False
    On Error Resume Next
    Set ppApp = GetObject(, "Powerpoint.Application")
    On Error GoTo -1: On Error GoTo 0: Err.Clear
    
    If ppApp Is Nothing Then
        Set ppApp = CreateObject("Powerpoint.Application")
        ppApp.Visible = True
        ppApp.presentations.Add
    End If
    
    If ppApp.ActivePresentation.Slides.Count = 0 Then
        Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, 12) 'ppLayoutBlank
    Else
        ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, 12
        Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
    End If
    
    Call Copy_Paste_to_PowerPoint(ppApp, ppSlide, ActiveSheet.Range("Print_Area"), xl_Bitmap)
    
    Application.ScreenUpdating = True
    
    Set ppApp = Nothing
    Set ppSlide = Nothing
    
End Sub