title: Excel VBA to Create PowerPoint Presentation
body: <p>Looking for some help on updating a VBA Script that completes the following (basic algorithm):</p>
  
  <ol>
  <li>Excel Template with formulas and macros creates a custom report consisting of approximately 30 charts</li>
  <li>Macro called “CreatePowerPointPresentation” is used to transfer these charts into a specific PowerPoint template in specific format</li>
  <li>The macros uses the slides contained in the template to create the first 6 slides</li>
  <li>The macro then adds slides (transitions and content slides)</li>
  </ol>
  
  <p><strong>Note</strong>: This macro was actually created based on a feedback from this forum</p>
  
  <p>This macro works great in Windows 7 with Office 2013, but generates errors in Windows 10, Office 2016 after slide 8 is created, randomly during one of the paste chart actions, but never gets past slide 10 of a 17-slide deck.</p>
  
  <p><strong>Errors:</strong></p>
  
  <pre><code>Runtime Error '-2147188160 (80048240)
  Method 'PasteSpecial'of object 'Shapes' failed.
  </code></pre>
  
  <p>Or</p>
  
  <pre><code>Runtime Error '-2147023170 (800706be)':
  Automation Error 
  The Remote procedure call failed.
  </code></pre>
  
  <p>I'm not sure if this is an object issue or some other piece that I'm missing.</p>
  
  <p><strong>Code below:</strong> </p>
  
  <pre><code>Sub CreatePowerPointPresentation()
  '=========================================================================
  'Create PowerPoint Presentation
  'Assigned to Index Tab
  '==========================================================================
  
  
          Dim newPowerPoint As PowerPoint.Application
          Dim activeSlide As PowerPoint.Slide
          Dim CHT As Excel.ChartObject
          Dim fmt As String
          Dim hgt As String
          Dim wth As String
  
  
  ‘this code allows for the user to select whether to paste the charts as Excel Charts or PNG Formatted images.
  
  Sheets("Index").Select
              If Range("AB7").Value = "Excel Charts" Then
                  fmt = ppPasteDefault
              Else
                  fmt = ppPastePNG
              End If
  
     'Establishes the global height and width of the graphics or charts pasted from Excel
          hgt = 280
          wth = 710
  
     'Look for existing instance
          On Error Resume Next
          Set newPowerPoint = GetObject(, "PowerPoint.Application")
          On Error GoTo 0
  
      'Create a new PowerPoint
          If newPowerPoint Is Nothing Then
          Set newPowerPoint = New PowerPoint.Application
          End If
      'Make a presentation in PowerPoint
          If newPowerPoint.Presentations.Count = 0 Then
          newPowerPoint.Presentations.Add
  
          End If
  
             'Show the PowerPoint
              newPowerPoint.Visible = True
              Application.EnableEvents = True
              Application.ScreenUpdating = True
  
             'Apply Template &amp; Create Title Slide 1
  
               newPowerPoint.ActivePresentation.ApplyTemplate Application.DefaultFilePath &amp; "\file.potx"
  
              'Set presentation to be 16x9
              'AppActivate ("Microsoft PowerPoint")
                  With newPowerPoint.ActivePresentation.PageSetup
                  .SlideSize = ppSlideSizeOnScreen16x9
                  .FirstSlideNumber = 1
                  .SlideOrientation = msoOrientationHorizontal
                  .NotesOrientation = msoOrientationVertical
                 End With
  'Create Slides 2-6 these are imported from the template
  newPowerPoint.ActivePresentation.Slides.InsertFromFile Application.DefaultFilePath &amp; "\File.potx", 0, 1
  
  'Create Slide 7
  
  newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
  newPowerPoint.ActivePresentation.Slides(7).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(33)
  Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
  
  With newPowerPoint.ActivePresentation.Slides(7)
                  .Shapes("Title 1").TextFrame.TextRange.Text = "Title1"
  End With
              newPowerPoint.ActiveWindow.ViewType = ppViewSlide
  
  ‘Create Slide 8 – Quad Chart Slide
  
  newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutBlank
  newPowerPoint.ActivePresentation.Slides(8).CustomLayout = newPowerPoint.ActivePresentation.SlideMaster.CustomLayouts(13)
  newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
  newPowerPoint.ActivePresentation.Slides(8).Shapes("Title 1").TextFrame.TextRange.Text = "Title 1"
  Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
  newPowerPoint.ActiveWindow.ViewType = ppViewSlide
  
          'Upper Left
              Sheets("Charts").Select
              ActiveSheet.ChartObjects("Chart 3").Select
              ActiveChart.ChartArea.Copy
              newPowerPoint.ActiveWindow.ViewType = ppViewSlide
              activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select
  
            'Adjust the positioning of the Chart on Powerpoint Slide
             newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
             newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75
             newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
             newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
             newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345
  
          'Upper Right
              Sheets("Charts").Select
              ActiveSheet.ChartObjects("Chart 2").Select
              ActiveChart.ChartArea.Copy
              newPowerPoint.ActiveWindow.ViewType = ppViewSlide
              activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select
  
             newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 350
             newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 75
             newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
             newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
             newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 345
  
  
          'Lower Left
              Sheets("Charts").Select
              ActiveSheet.ChartObjects("Chart 4").Select
              ActiveChart.ChartArea.Copy
              newPowerPoint.ActiveWindow.ViewType = ppViewSlide
              activeSlide.Shapes.PasteSpecial(DataType:=fmt).Select
  
              newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
              newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 230
              newPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
              newPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 145
              newPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 690
  
  
  ‘More slides……
  
      Application.EnableEvents = True
      Application.ScreenUpdating = True
      Set activeSlide = Nothing
      Set newPowerPoint = Nothing
  
  End Sub
  </code></pre>