Excel Q&Aサロン(VBA)にExcelの表をPowerPointのスライドに貼り付けようとするとエラーが発生する、との質問がありました。

下記コードをPowerPoint 2010環境で実行して動作を確認してみると、たしかに一部の形式でオートメーション エラー(-2147188160 (80048240))が発生しました。

Public Sub Sample1()
  Dim prs As Object
  Dim lay As Object
  
  Const ppPasteDefault = 0
  Const ppPasteBitmap = 1
  Const ppPasteEnhancedMetafile = 2
  Const ppPasteMetafilePicture = 3
  Const ppPasteGIF = 4
  Const ppPasteJPG = 5
  Const ppPastePNG = 6
  Const ppPasteText = 7
  Const ppPasteHTML = 8
  Const ppPasteRTF = 9
  Const ppPasteOLEObject = 10
  Const ppPasteShape = 11
  
  ActiveSheet.Range("B2:D7").Copy
  With CreateObject("PowerPoint.Application")
    .Visible = True
    Set prs = .Presentations.Add
    Set lay = GetCustomLayout(prs, "白紙")
    If Not lay Is Nothing Then
      With prs.Slides.AddSlide(1, lay).Shapes
        .PasteSpecial ppPasteDefault 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPasteBitmap 'OK
        '.PasteSpecial ppPasteEnhancedMetafile 'OK
        '.PasteSpecial ppPasteMetafilePicture 'OK
        '.PasteSpecial ppPasteGIF 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPasteJPG 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPastePNG 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPasteText 'OK
        '.PasteSpecial ppPasteHTML 'オートメーション エラー(-2147188160 (80048240))
        '.PasteSpecial ppPasteRTF 'OK
        '.PasteSpecial ppPasteOLEObject 'OK
        '.PasteSpecial ppPasteShape 'オートメーション エラー(-2147188160 (80048240))
      End With
    End If
  End With
End Sub

Private Function GetCustomLayout(ByVal TargetPresentation As Object, _
                                 ByVal LayoutName As String) As Object
  Dim ret As Object
  Dim c As Object
  
  For Each c In TargetPresentation.SlideMaster.CustomLayouts
    If c.Name = LayoutName Then
      Set ret = c
      Exit For
    End If
  Next
  Set GetCustomLayout = ret
End Function

引っ掛かるのは一部のDataTypeで、さらに手作業で貼り付け作業を行うとエラーが発生しないので、不可解な動作に思えます。

ただ、手作業で問題が無いのであれば、下記コードのように直接コマンドを実行(ExecuteMso)することで、エラーを回避することができます。

Public Sub Sample2()
  Dim prs As Object
  Dim sld As Object
  Dim lay As Object
  Dim r As Object, c As Object
  
  ActiveSheet.Range("B2:D7").Copy
  With CreateObject("PowerPoint.Application")
    .Visible = True
    Set prs = .Presentations.Add
    Set lay = GetCustomLayout(prs, "白紙")
    If Not lay Is Nothing Then
      Set sld = prs.Slides.AddSlide(1, lay)
      .CommandBars.ExecuteMso "PasteSourceFormatting"
      
      With sld
        '貼り付け待ち
        While .Shapes.Count < 1
          DoEvents
        Wend
        '----- 以下装飾 -----
        With .Shapes.Range(.Shapes.Count)
          .Width = 640
          .Height = 480
          .Align msoAlignCenters, True '左右中央揃え
          .Align msoAlignMiddles, True '上下中央揃え
          If .HasTable = True Then
            '各セルのフォントサイズ変更
            For Each r In .Table.Rows
              For Each c In r.Cells
                c.Shape.TextFrame2.TextRange.Font.Size = 24
              Next
            Next
          End If
        End With
        '--------------------
      End With
    End If
  End With
End Sub

Private Function GetCustomLayout(ByVal TargetPresentation As Object, _
                                 ByVal LayoutName As String) As Object
  Dim ret As Object
  Dim c As Object
  
  For Each c In TargetPresentation.SlideMaster.CustomLayouts
    If c.Name = LayoutName Then
      Set ret = c
      Exit For
    End If
  Next
  Set GetCustomLayout = ret
End Function

上記ExecuteMsoメソッドの引数であるコントロールID(PasteSourceFormatting(元の書式を保持)、PasteAsEmbedded(埋め込み)、PasteExcelTableDestinationTableStyle(貼り付け先のスタイルを使用)等)は下記リンク先からダウンロードできる、コントロールIDリストに記載されているので、必要に応じて参照してください。