Paste a range from Excel in to PowerPoint whilst keeping formatting

Question

I'm trying to automate the production of a PowerPoint presentation from an Excel report. I've previously done this manually and not had an issue.

When I copy a range from Excel, I'd paste it in to PowerPoint and choose Keep Source Formatting from the options. I'd then resize the table to how I want it to display on the slide and if necessary change the font size.

Doing this in VBA, I can't find an equivalent method to paste the table.

Having set up my workbook and PowerPoint, and copied my range fine, I use this to paste the table.

Slide2.Shapes.PasteSpecial ppPasteEnhancedMetafile

I've also tried

Slide2.Shapes.PasteSpecial ppPasteOLEObject

Both paste the tables ok, but once I resize the shape, the text all distorts, and I'm unable to edit the text size, unlike when I paste it manually.

What method should I be utilising to keep the functionality that I'd get by doing this manually? I don't particularly need the table linked back to Excel, it can just be a text table in PowerPoint.

Any guidance would be much appreciated thanks.

For info, I'm using Office 2010.

Here's my full code..

'Define public variables
  'PowerPoint variables
  Public PPApp As PowerPoint.Application
  Public PPPres As PowerPoint.Presentation

  'Data variables
  Public YYYY   As String
  Public YYMM   As String
  Public MonYy7 As String
  Public Mth    As String
  Public Qtr    As String

  'Location variables
  Public rptPath As String

Public Function GetLayout(LayoutName As String, _
                          Optional ParentPresentation As Presentation = Nothing) As CustomLayout

 If ParentPresentation Is Nothing Then
  Set ParentPresentation = PPPres
 End If

 Dim oLayout As CustomLayout
 For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
  If oLayout.Name = LayoutName Then
   Set GetLayout = oLayout
   Exit For
  End If
 Next
End Function

Sub Dates()
 Dim MthEnd As Date
 MthEnd = DateSerial(Year(Date), Month(Date), 0)

 YYYY = Format(MthEnd, "YYYY")
 YYMM = Format(MthEnd, "YYMM")
 MonYy7 = Format(MthEnd, "MMMM YYYY")
 Mth = Format(MthEnd, "MMM")

 'Quarter
 Quarter = Round(Month(MthEnd) / 3, 0)
 If Quarter = 1 Then
  Qtr = "Q" & Quarter & " " & YYYY
 ElseIf Quarter = 2 Then
  Qtr = "H1 " & YYYY
 ElseIf Quarter = 3 Then
  Qtr = "Q" & Quarter & " " & YYYY
 End If
End Sub

Sub Produce_Pack()
 'Setup dates
 Call Dates

 'Setup reference to the ARA workbook
 Dim wb As Workbook
 Set wb = ThisWorkbook

 'Setup reference to worksheet range
 Dim rng As Range

 'Setup reference to the worksheet
 Dim ws As Worksheet
 Set ws = wb.Worksheets("Pack Source Tables")

 'Setup reference to PowerPoint shape
 Dim pShape As PowerPoint.Shape

 'Open PowerPoint
 Set PPApp = CreateObject("PowerPoint.Application")

 'Create a new presentation
 Set PPPres = PPApp.Presentations.Add
 Application.Wait (Now + TimeValue("0:00:05"))

 'Set presentation slide references
 Dim oSlides As Slides
 Dim oSlide As Slide

 Set oSlides = PPPres.Slides

 'Set slide dimensions
  'Conversion of CMs to Points is * 28.34646
  PPPres.PageSetup.SlideHeight = 21# * 28.34646
  PPPres.PageSetup.SlideWidth = 29.7 * 28.34646

 'Apply the Risk template
 PPPres.ApplyTemplate ("C:\Template.potx")

 'Text variable
 Dim txt As String

 'Slide 1
   'Create slide
   Dim Slide1 As PowerPoint.Slide
   Set Slide1 = PPPres.Slides.Add(1, ppLayoutCustom) 'Default front cover

   'Text 1
   If Mth = "Dec" Then
    txt = "Title 1" & YYYY
   Else
    txt = "Sub Title" & vbNewLine & Qtr
   End If

   Slide1.Shapes("Title 1").TextFrame.TextRange.Text = txt

   'Text 2
   txt = "Sub Title 2"

   Slide1.Shapes("Text Placeholder 2").TextFrame.TextRange.Text = txt

   'Text 3
   txt = MonYy7

   Slide1.Shapes("Text Placeholder 3").TextFrame.TextRange.Text = txt

 'Slide 2
   'Create slide
    Set oSlide = oSlides.AddSlide(oSlides.Count + 1, GetLayout("Slide Layout 5"))

    Dim Slide2 As PowerPoint.Slide
    Set Slide2 = oSlide

    Slide2.Shapes("Content Placeholder 1").Delete

    'Title text
    txt = "Annual Report & Accounts (ARA)"
    Slide2.Shapes("Title 1").TextFrame.TextRange.Text = txt

    'Copy tables from Excel
    Set rng = ws.Range("A:A")

    rng.ColumnWidth = 22.75

    Set rng = ws.Range("A4:C27")

    'Copy the table range
    Application.CutCopyMode = False
    rng.Copy
    Application.Wait (Now + TimeValue("0:00:02"))

    'Paste the table in to the slide
    Slide2.Shapes.PasteSpecial ppPasteOLEObject

    'Name the new shape object
    Set pShape = Slide2.Shapes(Slide2.Shapes.Count)
    pShape.Name = "Slide_2_Table_1"
    pShape.LockAspectRatio = False

    'Set the position and size of the new shape.
     'Conversion of CMs to Points is * 28.34646
     pShape.Left = 1.3 * 28.34646
     pShape.Top = 5.64 * 28.34646
     pShape.Height = 13.66 * 28.34646
     pShape.Width = 22.75 * 28.34646

End Sub

Have you tried recording a macro script when you do it manually? If so, how does it differ from your code? — RBarryYoung
I hadn't thought of that no. However recording from Excel stops once I move focus to PowerPoint, and I can't see anywhere to record a macro within PowerPoint, so I'm not sure if I can do that. — Satkin2
Go to "Customize the Ribbon" under File..Options and enable the Developer tab in the right-hand listbox. — RBarryYoung
Ehhh, never mind, looks like the removed the Record Macro ability from PowerPoint after 2007. Great. — RBarryYoung
Try using ppPasteEnhancedMetafile with .PasteSpecial, instead of ppPasteOLEObject. — RBarryYoung

Intricate Intricate · Accepted Answer · 2018-07-05T05:24:27

the issue is that you are pasting is as an image due to which issues stretching, coloring or font size changes are not possible.

What you need to do is to paste as a normal table and then you can play around with the format.

Below is the code extracted from your code which works perfectly and you can make the changes in the table pasted in PowerPoint.

Paste the code in the Excel VBA developer.

In the excel, enter some content as the below image example

then update this code in the excel VBA and execute it

    'Define public variables

  'Data variables
  Dim YYYY   As String
  Dim YYMM   As String
  Dim MonYy7 As String
  Dim Mth    As String
  Dim Qtr    As String

  'Location variables
  Dim rptPath As String

Sub Dates()
 Dim MthEnd As Date
 MthEnd = DateSerial(Year(Date), Month(Date), 0)

 YYYY = Format(MthEnd, "YYYY")
 YYMM = Format(MthEnd, "YYMM")
 MonYy7 = Format(MthEnd, "MMMM YYYY")
 Mth = Format(MthEnd, "MMM")

 'Quarter
 Quarter = Round(Month(MthEnd) / 3, 0)
 If Quarter = 1 Then
  Qtr = "Q" & Quarter & " " & YYYY
 ElseIf Quarter = 2 Then
  Qtr = "H1 " & YYYY
 ElseIf Quarter = 3 Then
  Qtr = "Q" & Quarter & " " & YYYY
 End If
End Sub

Sub Produce_Pack()

  Dim PPApp As PowerPoint.Application
  Dim PPPres As PowerPoint.Presentation


 'Setup dates
 Call Dates

 'Setup reference to the ARA workbook
 Dim wb As Workbook
 Set wb = ThisWorkbook

 'Setup reference to worksheet range
 Dim rng As Range

 'Setup reference to the worksheet
 Dim ws As Worksheet
 Set ws = wb.Worksheets("Sheet1")

 'Setup reference to PowerPoint shape
 Dim pShape As PowerPoint.Shape

 'Open PowerPoint
 Set PPApp = CreateObject("PowerPoint.Application")

 'Create a new presentation
 Set PPPres = PPApp.Presentations.Add
 'Application.Wait (Now + TimeValue("0:00:05"))

 'Set presentation slide references
 Dim oSlides As Slides
 Dim oSlide As Slide

 Set oSlides = PPPres.Slides

 'Set slide dimensions
  'Conversion of CMs to Points is * 28.34646
  'PPPres.PageSetup.SlideHeight = 21# * 28.34646
  'PPPres.PageSetup.SlideWidth = 29.7 * 28.34646

 'Apply the Risk template
 'PPPres.ApplyTemplate ("C:\Template.potx")

 'Text variable
 Dim txt As String

 'Slide 1
   'Create slide
   Dim Slide1 As PowerPoint.Slide
   Set Slide1 = PPPres.Slides.Add(1, pplayoutcustom) 'Default front cover

   'Text 1
   If Mth = "Dec" Then
    txt = "Title 1" & YYYY
   Else
    txt = "Sub Title" & vbNewLine & Qtr
   End If

   Slide1.Shapes("Title 1").TextFrame.TextRange.Text = txt


    'Copy tables from Excel
    Set rng = ws.Range("A:A")

    rng.ColumnWidth = 22.75

    Set rng = ws.Range("A1:C15")

    'Copy the table range
    Application.CutCopyMode = False
    rng.Copy
    'Application.Wait (Now + TimeValue("0:00:02"))

    'Paste the table in to the slide
    Slide1.Shapes.PasteSpecial ppPasteHTML, msoFalse  '<---- the actual change

    'Name the new shape object
    Set pShape = Slide1.Shapes(Slide1.Shapes.Count)
    pShape.Name = "Slide_1_Table_1"
    pShape.LockAspectRatio = False

    'Set the position and size of the new shape.
     'Conversion of CMs to Points is * 28.34646
     pShape.Left = 1.3 * 28.34646
     pShape.Top = 5.64 * 28.34646
     pShape.Height = 13.66 * 28.34646
     pShape.Width = 22.75 * 28.34646

End Sub

The arrow pointed is the only change, I have made the code to work quicker for me and commenting out the rest

Rest you can play with the code and it will work.

Hopefully this is the answer that you are looking for

Cheers

Paste a range from Excel in to PowerPoint whilst keeping formatting

1 Answers