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

Bob1978

New Member
Joined
Jan 25, 2013
Messages
29
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

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

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
4,129
Hi Bob

Please test this:

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

New Member
Joined
Jan 25, 2013
Messages
29
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

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

Well-known Member
Joined
Oct 30, 2011
Messages
4,129
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.
 

Watch MrExcel Video

Forum statistics

Threads
1,129,811
Messages
5,638,488
Members
417,027
Latest member
wlknspc7

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
Top