title: Paste a range from Excel in to PowerPoint whilst keeping formatting
body: <p>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.</p>
  
  <p>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.</p>
  
  <p>Doing this in VBA, I can't find an equivalent method to paste the table.</p>
  
  <p>Having set up my workbook and PowerPoint, and copied my range fine, I use this to paste the table.</p>
  
  <pre><code>Slide2.Shapes.PasteSpecial ppPasteEnhancedMetafile
  </code></pre>
  
  <p>I've also tried</p>
  
  <pre><code>Slide2.Shapes.PasteSpecial ppPasteOLEObject
  </code></pre>
  
  <p>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.</p>
  
  <p>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.</p>
  
  <p>Any guidance would be much appreciated thanks.</p>
  
  <p>For info, I'm using Office 2010.</p>
  
  <p>Here's my full code..</p>
  
  <pre><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" &amp; Quarter &amp; " " &amp; YYYY
   ElseIf Quarter = 2 Then
    Qtr = "H1 " &amp; YYYY
   ElseIf Quarter = 3 Then
    Qtr = "Q" &amp; Quarter &amp; " " &amp; 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" &amp; YYYY
     Else
      txt = "Sub Title" &amp; vbNewLine &amp; 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 &amp; 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
  </code></pre>