Results 1 to 2 of 2

Thread: Copy/Paste Excel Range/Chart into Powerpoint VBA

  1. #1
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    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.

    Code:
    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


    Code:
    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
    Last edited by Admin; 11-27-2012 at 02:55 PM.
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  2. #2
    Senior Member LalitPandey87's Avatar
    Join Date
    Sep 2011
    Posts
    222
    Rep Power
    14
    Revised routine, with excel image adjustment in powerpoint slide.

    Code:
    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

    Code:
    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

Similar Threads

  1. Add VBA Reference From Another Application Excel To PowerPoint
    By ds1001 in forum Rajan Verma's Corner
    Replies: 1
    Last Post: 06-02-2013, 02:43 PM
  2. VBA -- Copy/Paste across sheets
    By Rasm in forum Excel Help
    Replies: 4
    Last Post: 09-21-2012, 02:07 PM
  3. Replies: 1
    Last Post: 05-20-2012, 12:23 PM
  4. Replies: 2
    Last Post: 04-08-2012, 09:42 AM
  5. Trapping Copy To Range Before Copy/Cut Paste
    By Rasm in forum Excel Help
    Replies: 4
    Last Post: 04-07-2011, 07:48 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •