# VBA code for Excel tables into ppt - automation



## surya444 (Dec 9, 2022)

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 (Dec 11, 2022)

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 (Dec 20, 2022)

Trebor76 said:


> Hi surya444,
> 
> Welcome to MrExcel!!
> 
> ...


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 (Dec 20, 2022)

> 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


----------

