VBA code to copy a table from Excel into a Powerpoint slide

[Bob1978]

Hi,

I currently have a table in Excel range A1 to S12, which I would like copied in to a blank slide in Powerpoint.

Once in Powerpoint I need the formatting to be the same as it is in Excel e.g. cell fill colour the same, column width the same etc.

I would like the table to be centred in the slide and a title above the table to say "Table 1"

I have tried working with the below code but my main problem has been the formatting part of the slide

If someone could help me, I would be very grateful

Thanks

Bob

Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.ShapeRange

'Copy Range from Excel
  Set rng = ThisWorkbook.ActiveSheet.Range("A1:S12")

'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
  
'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate
    
'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

'Clear The Clipboard
  CutCopyMode = False

End Sub

 

[Worf]

Hi Bob

Please test this:

Sub Bob()
Dim tb As PowerPoint.Table, rng As Excel.Range, PowerPointApp As PowerPoint.Application
Dim Pres As PowerPoint.Presentation, ttop%, i%, j%, LS As PowerPoint.Slide
Set rng = ThisWorkbook.ActiveSheet.Range("A1:S12")
'  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
PowerPointApp.Visible = True
PowerPointApp.Activate
Set Pres = PowerPointApp.Presentations.Add
Set LS = Pres.Slides.Add(1, ppLayoutTitleOnly)
With LS.Shapes.Title
    .Top = 5
    .TextFrame.TextRange.Text = "Table 1"
    .Height = Pres.PageSetup.SlideHeight / 10
    ttop = .Height + 10
End With
rng.Copy
PowerPointApp.ActiveWindow.Panes(2).Activate      ' make sure focus is right
Pres.Windows(1).View.Paste
Set tb = LS.Shapes(LS.Shapes.Count).Table
With tb.Parent
    .Height = Pres.PageSetup.SlideHeight - ttop
    .Width = Pres.PageSetup.SlideWidth - 10
    .Left = 5
    .Top = ttop
End With
 For i = 1 To tb.Rows.Count
    For j = 1 To tb.Columns.Count
        tb.Cell(i, j).Shape.Fill.ForeColor.RGB = rng.Cells(i, j).Interior.Color
    Next
Next
For j = 1 To tb.Columns.Count
    tb.Columns(j).Width = (rng.Columns(j).Width / rng.Width) * tb.Parent.Width
Next
End Sub

 

[Bob1978]

Hi worf

Thanks very much for taking the time to help me.

I have tried your script but I got a Run time error 429 - ActiveX component can't create object.

Debug leads me to the line

Set PowerPointApp = GetObject(class:="PowerPoint.Application")

I have Microsoft Powerpoint 14.0 Object Library box ticked in the VBA project References, so i can't think what this would be.

Please could you help me?

Thanks

Bob

 

[Worf]

Hi Bob
Try removing the comment sign on the “on error resume next” line. The code is already prepared to create a new instance of PowerPoint if needed.