[ExcelVBA] Excelの表を元の書式を保持してPowerPointへ貼り付ける

以前書いた記事へ質問をいただきました。ExcelからオブジェクトをコピーしてPowerPointへ貼り付ける内容なのですが、「元の書式を保持」してっていうのがわりと曲者で、グラフのコピペは見かけるものの「表」のコピペは自分では試したことがなかったので、書いてみました。

関連記事

• Excelで作成したグラフ等を自動でPowerPointへ貼り付けるExcelVBA
• ExcelVBAからPowerPointへデータ貼付時のPasteSpecialデータタイプについて

こちらは、上の記事へのコメントからの派生記事です。「元の書式を保持」するテクニックを下の記事のコメントで教えていただいたものをヒントにしています。たかぴーさんありがとうございます！

仕様

まずはこのようなExcelシートを想定します。

列数は同数、行数はバラバラとのことでしたので、行数についてはシートごとにB3から最終端を取得してコピーすることにします。

後述のコードを実行するとPowerPointが起動して以下のような結果になります。

シートの特定範囲をコピーして「元の書式を保持」して貼り付けるので、図のように貼り付け後もテキストや書式の変更ができます。

コード

昔書いたものより自分なりのコードの書き方が変わっているので変数の位置とか変わっていますが、動作に問題はありません。

Sub TableCopyToPPT()
  'エラー時はERROR_HANDLERへ
  On Error GoTo ERROR_HANDLER
    
  'PowerPointを起動
  Dim ppApp As Object
  Set ppApp = CreateObject("PowerPoint.Application")
  If ppApp Is Nothing Then
    Err.Raise 1000, , "PowerPoint の起動に失敗しました"
  End If
  
  '新規プレゼンテーション作成
  Dim ppPst As Object
  Set ppPst = ppApp.Presentations.Add
  
  '倍率
  Dim rate  As Double: rate = 1.8
  
  '繰り返し
  Dim i As Long
  For i = 1 To ThisWorkbook.Worksheets.Count 'Excelシートの数だけ
    'PowerPoint新規スライド
    Dim ppSld As Object
    Set ppSld = ppPst.Slides.Add(Index:=i, Layout:=12) '追加
    ppSld.Select '選択
    Dim shCount As Long
    shCount = ppSld.Shapes.Count '貼り付け前のシェイプ数取得
     
    '指定範囲をコピー
    With ThisWorkbook
      Dim lastRow As Long
      lastRow = .Worksheets(i).Range("B3").End(xlDown).Row 'B3セルから下方向で最終端を取得
      .Worksheets(i).Range("B2:I" & lastRow).Copy 'コピー
    End With
    
    '貼り付け
    ppApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting" '元の書式を保持
     
    'スライド上のシェイプ数が変わるまで待機（貼り付けのタイムラグ対策）
    Do While shCount = ppSld.Shapes.Count
      DoEvents
    Loop

    '貼り付けた表の位置・サイズを補正
    With ppSld.Shapes(ppSld.Shapes.Count)
      .Top = 50 '上からの位置
      .Left = 50 '左からの位置
      Dim defW As Long: defW = .Width 'デフォルトの横幅取得
      Dim defH As Long: defH = .Height 'デフォルトの縦幅取得
      .Width = defW * rate '倍率を掛けたものへサイズ変更
      .Height = defH * rate
    End With
  Next i
 
  'PowerPointを保存
  ppApp.ActivePresentation.SaveAs Filename:=ThisWorkbook.Path & "/" & Replace(ActiveWorkbook.Name, ".xlsm", ".pptx")
   
  GoTo TERMINATE
 
ERROR_HANDLER: 'エラーの場合
  MsgBox Err.Description, vbCritical 'エラーメッセージ出力

TERMINATE: '最終処理
  Set ppApp = Nothing
  Set ppPst = Nothing
  Set ppSld = Nothing
End Sub

37行目が「元の書式を保持」の部分ですが、グラフだと「”PasteExcelChartSourceFormatting”」なのですが表だと「”PasteExcelTableSourceFormatting”」で動きました。これは実際にやってみないと気付かなかったな…。

そのほか、だいたいの流れはコメントアウトのメモを読んでいただければいいかなと思うのですが、どうも表の貼り付けだと縦横比固定が効かないのかな…？　貼り付けた表のサイズを変更する部分で、LockAspectRatioプロパティをTrueにしても引き延ばされてしまいました。苦肉の策で縦横とも元の大きさに指定の倍率を掛けるという方法をとっていますが、縦横比固定じゃなくてもよければお好きな数値にしていただければと思います。

以上です！