VBA code for Excel tables into ppt - automation

[surya444]

Hi all,

I have an excel file used to generate ~15 tables of data. This report needs to be generated every week and I wanted to automate the 'from excel to ppt' updaiton. I am using the below code. it works for the active sheet, but how can I make the macro to go to the next sheet, copy paste a certain range and add as data in a new slide in the ppt ? Please help!!


Sub CopyPaste()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+m
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim activeSlide As PowerPoint.slide

'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("J13:Y23")

'Create an Instance of PowerPoint
On Error Resume Next

'Is PowerPoint already opened?
Set PowerPointApp = GetObject(Class:="PowerPoint.Application")

'Clear the error between errors
Err.Clear

'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")

'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False

'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 10) '11 = ppLayoutTitleOnly

'Copy Excel Range
rng.Copy

'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
myShape.Left = 66
myShape.Top = 152

'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate

'Clear The Clipboard
Application.CutCopyMode = False


'Add a new slide where we will paste the chart
myPresentation.ActivePresentation.Slides.Add myPresentation.ActivePresentation.activeSlide.Count + 1, ppLayoutTitleOnly


AppActivate "PowerPoint"
Set activeSlide = Nothing
Set newPowerPoint = Nothing


End Sub

 

[Trebor76]

Hi surya444,

Welcome to MrExcel!!

See how this goes:

Option Explicit
Sub CopyPaste()
    '
    ' Macro1 Macro
    '
    ' Keyboard Shortcut: Ctrl+m
    Dim rng As Range
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object
    'Dim activeslide As PowerPoint.slide
    'Dim activeslide As Object
    Dim ws As Worksheet
    Dim varSheet As Variant
    
    'Copy Range from Excel
    'Set rng = ThisWorkbook.ActiveSheet.Range("J13:Y23")
    
    Application.ScreenUpdating = False
    
    'Create an Instance of PowerPoint
    On Error Resume Next
    
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
    
    'Clear the error between errors
    Err.Clear
    
    'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
    If Err.Number = 429 Then
        Application.ScreenUpdating = True
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
    On Error GoTo 0
    'Optimize Code
    Application.ScreenUpdating = False
    
    'Create a New Presentation
    Set myPresentation = PowerPointApp.Presentations.Add
    
    For Each varSheet In Array("Sheet1-J13:Y23", "Sheet2-A2:K11") '<-Sheet names and their ranges to be copied to PowerPoint. Change to suit.
        'Add a slide to the Presentation
        Set mySlide = myPresentation.Slides.Add(1, 10) '10 = ClipArt and text
        Set ws = ThisWorkbook.Sheets(CStr(Split(varSheet, "-")(0)))
        Set rng = ws.Range(CStr(Split(varSheet, "-")(1)))
        'Copy Excel Range
        rng.Copy
        'Paste to PowerPoint and position
        mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
        'Set position:
        myShape.Left = 66
        myShape.Top = 152
    Next varSheet
    
    With Application
        .CutCopyMode = False 'Clear The Clipboard
        .ScreenUpdating = True
    End With
    
    'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    
    Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
    
    AppActivate "PowerPoint"
    Set PowerPointApp = Nothing
       
End Sub

Regards,

Robert

 

[surya444]

Hi surya444,

Welcome to MrExcel!!

See how this goes:

Option Explicit
Sub CopyPaste()
    '
    ' Macro1 Macro
    '
    ' Keyboard Shortcut: Ctrl+m
    Dim rng As Range
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object
    'Dim activeslide As PowerPoint.slide
    'Dim activeslide As Object
    Dim ws As Worksheet
    Dim varSheet As Variant
   
    'Copy Range from Excel
    'Set rng = ThisWorkbook.ActiveSheet.Range("J13:Y23")
   
    Application.ScreenUpdating = False
   
    'Create an Instance of PowerPoint
    On Error Resume Next
   
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
   
    'Clear the error between errors
    Err.Clear
   
    'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
   
    'Handle if the PowerPoint Application is not found
    If Err.Number = 429 Then
        Application.ScreenUpdating = True
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
    On Error GoTo 0
    'Optimize Code
    Application.ScreenUpdating = False
   
    'Create a New Presentation
    Set myPresentation = PowerPointApp.Presentations.Add
   
    For Each varSheet In Array("Sheet1-J13:Y23", "Sheet2-A2:K11") '<-Sheet names and their ranges to be copied to PowerPoint. Change to suit.
        'Add a slide to the Presentation
        Set mySlide = myPresentation.Slides.Add(1, 10) '10 = ClipArt and text
        Set ws = ThisWorkbook.Sheets(CStr(Split(varSheet, "-")(0)))
        Set rng = ws.Range(CStr(Split(varSheet, "-")(1)))
        'Copy Excel Range
        rng.Copy
        'Paste to PowerPoint and position
        mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
        'Set position:
        myShape.Left = 66
        myShape.Top = 152
    Next varSheet
   
    With Application
        .CutCopyMode = False 'Clear The Clipboard
        .ScreenUpdating = True
    End With
   
    'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate
   
    Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
   
    AppActivate "PowerPoint"
    Set PowerPointApp = Nothing
      
End Sub

Regards,

Robert

Hi Trebor,

Thank you for the reply, it works

Is there a way I could do it this way --> a 2-columned table with the sheet name and corresponding range to be copied? As the names of the sheets keep changing now and then..

 

[Trebor76]

Thank you for the reply, it works

Thanks for letting us know and you're welcome

Is there a way I could do it this way --> a 2-columned table with the sheet name and corresponding range to be copied? As the names of the sheets keep changing now and then.

Try this where the sheet name and its associated range are in columns A and B (respectively) of Sheet3 (change where I've commented "Change to suit" if need be):

Option Explicit
Sub CopyPaste()
    '
    ' Macro1 Macro
    '
    ' Keyboard Shortcut: Ctrl+m
    Dim rng As Range
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object
    Dim ws As Worksheet, wsTable As Worksheet
    Dim lngRow As Long, lngRowFrom As Long, lngRowTo As Long
    
    'Copy Range from Excel
    'Set rng = ThisWorkbook.ActiveSheet.Range("J13:Y23")
    
    Application.ScreenUpdating = False
    
    'Create an Instance of PowerPoint
    On Error Resume Next
    
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
    
    'Clear the error between errors
    Err.Clear
    
    'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
    If Err.Number = 429 Then
        Application.ScreenUpdating = True
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
    On Error GoTo 0
    'Optimize Code
    Application.ScreenUpdating = False
    
    'Create a New Presentation
    Set myPresentation = PowerPointApp.Presentations.Add
    
    Set wsTable = ThisWorkbook.Sheets("Sheet3") '<-Sheet name for the table (sheet name and range) to populate PowerPoint. Change to suit.
    lngRowFrom = 2 '<-Starting row number for the sheet name and its associate range. Change to suit.
    lngRowTo = wsTable.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row '<-Assumes the sheet name and its associate range are in columns A and B respectively. Change to suit.
    
    For lngRow = lngRowFrom To lngRowTo
        'Add a slide to the Presentation
        Set mySlide = myPresentation.Slides.Add(1, 10) '10 = ClipArt and text
        Set ws = ThisWorkbook.Sheets(CStr(wsTable.Range("A" & lngRow))) '<-Assumes the sheet name is in Col. A of 'wsTable'. Change to suit.
        Set rng = ws.Range(CStr(wsTable.Range("B" & lngRow))) '<-Assumes the range for the sheet is in Col. B of 'wsTable'. Change to suit.
        'Copy Excel Range
        rng.Copy
        'Paste to PowerPoint and position
        mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
        'Set position:
        myShape.Left = 66
        myShape.Top = 152
    Next lngRow
    
    With Application
        .CutCopyMode = False 'Clear The Clipboard
        .ScreenUpdating = True
    End With
    
    'Make PowerPoint Visible and Active
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    
    Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
    
    AppActivate "PowerPoint"
    Set PowerPointApp = Nothing
       
End Sub

Regards,

Robert