VBA: Copy Ranges to PowerPoint

MRGIBR

New Member
Joined
Jul 26, 2018
Messages
6
Hi,

I have a code which pastes range to PowerPoint slide:


Code:
Sub Copy_Paste_to_PowerPoint()
     
     'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
    Dim ppApp As PowerPoint.Application
    Dim ppSlide As PowerPoint.Slide
     
     'Original code sourced from Jon Peltier http://peltiertech.com/Excel/XL_PPT.html
     'This code developed at http://oldlook.experts-exchange.com:8080/Applications/MS_Office/Excel/Q_21337053.html
     
    Dim SheetName As String
    Dim TestRange As Range
    Dim TestSheet As Worksheet
    Dim TestChart As ChartObject
     
    Dim PasteChart As Boolean
    Dim PasteChartLink As Boolean
    Dim ChartNumber As Long
     
    Dim PasteRange As Boolean
    Dim RangePasteType As String
    Dim RangeName As String
    Dim AddSlidesToEnd As Boolean
     
     'Parameters
     
     'SheetName           - name of sheet in Excel that contains the range or chart to copy
     
     'PasteChart          -If True then routine will  copy and paste a chart
     'PasteChartLink      -If True then Routine will paste chart with Link; if = False then paste chart no link
     'ChartNumber         -Chart Object Number
     '
     'PasteRange          - If True then Routine will copy and Paste a range
     'RangePasteType      - Paste as Picture linked or unlinked, "HTML" or "Picture". See routine below for exact values
     'RangeName           - Address or name of range to copy; "B3:G9" "MyRange"
     'AddSlidesToEnd      - If True then appednd slides to end of presentation and paste.  If False then paste on current slide.
     
     'use active sheet. This can be a direct sheet name
    SheetName = ActiveSheet.Name
     
     'Setting PasteRange to True means that Chart Option will not be used
    PasteRange = True
    RangeName = "A1:B10"
    RangePasteType = "Picture"
    RangeLink = False
     
    PasteChart = False
    PasteChartLink = False
    ChartNumber = 1
     
    AddSlidesToEnd = True
     
     
     'Error testing
    On Error Resume Next
    Set TestSheet = Sheets(SheetName)
    Set TestRange = Sheets(SheetName).Range(RangeName)
    Set TestChart = Sheets(SheetName).ChartObjects(ChartNumber)
    On Error GoTo 0
     
    If TestSheet Is Nothing Then
        MsgBox "Sheet " & SheetName & " does not exist. Macro will exit", vbCritical
        Exit Sub
    End If
     
    If PasteRange And TestRange Is Nothing Then
        MsgBox "Range " & RangeName & " does not exist. Macro will exit", vbCritical
        Exit Sub
    End If
     
    If PasteRange = False And PasteChart And TestChart Is Nothing Then
        MsgBox "Chart " & ChartNumber & " does not exist. Macro will exit", vbCritical
        Exit Sub
    End If
     
     
     'Look for existing instance
    On Error Resume Next
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
     
     'Create new instance if no instance exists
    If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application
     'Add a presentation if none exists
    If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add
     
     'Make the instance visible
    ppApp.Visible = True
     
     'Check that a slide exits, if it doesn't add 1 slide. Else use the last slide for the paste operation
    If ppApp.ActivePresentation.Slides.Count = 0 Then
        Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
    Else
        If AddSlidesToEnd Then
             'Appends slides to end of presentation and makes last slide active
            ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
            ppApp.ActiveWindow.View.GotoSlide ppApp.ActivePresentation.Slides.Count
            Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
        Else
             'Sets current slide to active slide
            Set ppSlide = ppApp.ActiveWindow.View.Slide
        End If
    End If
     
     'Options for Copy & Paste Ranges and Charts
    If PasteRange = True Then
         'Options for Copy & Paste Ranges
        If RangePasteType = "Picture" Then
             'Paste Range as Picture
            Worksheets(SheetName).Range(RangeName).Copy
            ppSlide.Shapes.PasteSpecial(ppPasteDefault, link:=RangeLink).Select
        Else
             'Paste Range as HTML
            Worksheets(SheetName).Range(RangeName).Copy
            ppSlide.Shapes.PasteSpecial(ppPasteHTML, link:=RangeLink).Select
        End If
    Else
         'Options for Copy and Paste Charts
        Worksheets(SheetName).Activate
        ActiveSheet.ChartObjects(ChartNumber).Select
        If PasteChartLink = True Then
             'Copy & Paste Chart Linked
            ActiveChart.ChartArea.Copy
            ppSlide.Shapes.PasteSpecial(link:=True).Select
        Else
             'Copy & Paste Chart Not Linked
            ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
            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
     
    AppActivate ("PowerPoint")
    Set ppSlide = Nothing
    Set ppApp = Nothing
     
End Sub

However the ode is only focused on one range - Active sheet and indicated cells (as seen in the code)


How can I modify the code so the code will focus on several sheets within workbook and specific cell ranges in those sheets.


Thanks in advance.
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
Hi

Code:
Sub Main()                                          ' run me
Dim sn, ra, i%
sn = Array("sheet1", "sheet1", "sheet2", "sheet2")  ' sheet names
ra = Array("a1:b10", "c1:d10", "d1:e10", "f1:g10")  ' corresponding ranges
For i = LBound(sn) To UBound(sn)
    Copy_Paste_to_PP sn(i), ra(i)
Next
End Sub
Sub Copy_Paste_to_PP(ByVal sheetname$, ByVal rangename$)
     'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
    Dim ppApp As PowerPoint.Application, ppSlide As PowerPoint.Slide
     'Original code sourced from Jon Peltier http://peltiertech.com/Excel/XL_PPT.html
     'This code developed at http://oldlook.experts-exchange.com:8080/Applications/MS_Office/Excel/Q_21337053.html
    Dim TestRange As Range, TestSheet As Worksheet, TestChart As ChartObject
    Dim PasteChart As Boolean, rangelink
    Dim PasteChartLink As Boolean, ChartNumber As Long
    Dim PasteRange As Boolean, RangePasteType As String, AddSlidesToEnd As Boolean
     
     'Parameters
     
     'SheetName           - name of sheet in Excel that contains the range or chart to copy
     
     'PasteChart          -If True then routine will  copy and paste a chart
     'PasteChartLink      -If True then Routine will paste chart with Link; if = False then paste chart no link
     'ChartNumber         -Chart Object Number
     '
     'PasteRange          - If True then Routine will copy and Paste a range
     'RangePasteType      - Paste as Picture linked or unlinked, "HTML" or "Picture". See routine below for exact values
     'RangeName           - Address or name of range to copy; "B3:G9" "MyRange"
     'AddSlidesToEnd      - If True then appednd slides to end of presentation and paste.  If False then paste on current slide.
     
     'Setting PasteRange to True means that Chart Option will not be used
    PasteRange = True
    RangePasteType = "Picture"
    rangelink = False
    PasteChart = False
    PasteChartLink = False
    ChartNumber = 1
    AddSlidesToEnd = True
     'Error testing
    On Error Resume Next
    Set TestSheet = Sheets(sheetname)
    Set TestRange = Sheets(sheetname).Range(rangename)
    Set TestChart = Sheets(sheetname).ChartObjects(ChartNumber)
    On Error GoTo 0
    If TestSheet Is Nothing Then
        MsgBox "Sheet " & sheetname & " does not exist. Macro will exit", vbCritical
        Exit Sub
    End If
    If PasteRange And TestRange Is Nothing Then
        MsgBox "Range " & rangename & " does not exist. Macro will exit", vbCritical
        Exit Sub
    End If
    If PasteRange = False And PasteChart And TestChart Is Nothing Then
        MsgBox "Chart " & ChartNumber & " does not exist. Macro will exit", vbCritical
        Exit Sub
    End If
     'Look for existing instance
    On Error Resume Next
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
     'Create new instance if no instance exists
    If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application
     'Add a presentation if none exists
    If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add
     'Make the instance visible
    ppApp.Visible = True
     'Check that a slide exits, if it doesn't add 1 slide. Else use the last slide for the paste operation
    If ppApp.ActivePresentation.Slides.Count = 0 Then
        Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
    Else
        If AddSlidesToEnd Then
             'Appends slides to end of presentation and makes last slide active
            ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
            ppApp.ActiveWindow.View.GotoSlide ppApp.ActivePresentation.Slides.Count
            Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
        Else
             'Sets current slide to active slide
            Set ppSlide = ppApp.ActiveWindow.View.Slide
        End If
    End If
     'Options for Copy & Paste Ranges and Charts
    If PasteRange = True Then
         'Options for Copy & Paste Ranges
        If RangePasteType = "Picture" Then
             'Paste Range as Picture
            Worksheets(sheetname).Range(rangename).Copy
            ppSlide.Shapes.PasteSpecial(ppPasteDefault, Link:=rangelink).Select
        Else
             'Paste Range as HTML
            Worksheets(sheetname).Range(rangename).Copy
            ppSlide.Shapes.PasteSpecial(ppPasteHTML, Link:=rangelink).Select
        End If
    Else
         'Options for Copy and Paste Charts
        Worksheets(sheetname).Activate
        ActiveSheet.ChartObjects(ChartNumber).Select
        If PasteChartLink = True Then
             'Copy & Paste Chart Linked
            ActiveChart.ChartArea.Copy
            ppSlide.Shapes.PasteSpecial(Link:=True).Select
        Else
             'Copy & Paste Chart Not Linked
            ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
            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
    AppActivate ("PowerPoint")
    Set ppSlide = Nothing
    Set ppApp = Nothing
End Sub
 
Upvote 0
Thanks mate, it works just like was intended.

I added some features and works perfectly.

Thanks again
 
Upvote 0

Forum statistics

Threads
1,213,562
Messages
6,114,326
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top