[ExcelVBA] 指定フォルダ内のExcelファイルにあるすべてのグラフをPowerPointにコピペする

Excelシート上のオブジェクトをPowerPointにコピペするコードっていうのをいくつか書いているのですが、そこのコメントでいただいた質問から、こういうのもあったら何かに使えるのかなー、と思ったのを書いてみました。

関連記事

• Excelで作成したグラフ等を自動でPowerPointへ貼り付けるExcelVBA
• [VBA]PowerPointの指定したスライドへExcelグラフを最背面で貼り付ける
• [VBA]ExcelグラフをPowerPointへ任意の位置・大きさで貼り付ける

これの一番下の記事にいただいた質問です。こちらの方のはかなり仕様が決まってて、ぼんやり考えたコードは不要になっちゃったので、供養と思ってブログに書き散らします。

コードと解説

まずはざっくりな仕様説明として、

フォルダを指定して、その中に入っているxlsxファイルの、すべてのシート上にあるシェイプのなかからグラフ（Chart）だった場合のみ、新規pptxファイルにコピペしていきます。1シートにつき1枚スライドが追加され、グラフが複数存在する場合は右下にちょっとずつズレて貼り付けされていきます。貼り付けを行った場合、左上に該当のブック名とシート名がテキストボックスで挿入されます。

Sub copyToPPT()
  'フォルダ選択
  With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "C:\" '初期フォルダ指定
    If .Show = True Then
      Dim tgtPath As String: tgtPath = .SelectedItems(1) & "\" 'フォルダパスを取得
    Else
      Exit Sub 'キャンセルを押されたら終了
    End If
  End With
  
  'フォルダ内のxlsxファイルをコレクションに格納
  Dim XlsxList As Collection: Set XlsxList = New Collection
  Dim buff As String: buff = Dir(tgtPath & "*.xlsx")
  Dim hasFile As Boolean
  Do While buff <> ""
    XlsxList.Add buff
    buff = Dir()
    hasFile = True
  Loop
  If hasFile = False Then '存在チェック
    MsgBox "指定のフォルダにxlsxファイルが存在しません"
    Exit Sub
  End If
  
  On Error GoTo ERROR_HANDLER
  
  'PPTの準備
  Dim pp As Object
  Set pp = CreateObject("PowerPoint.Application").Presentations.Add 'PowerPoint新規プレゼンテーション作成
  
  Dim bookName As Variant 'ループ用変数
  For Each bookName In XlsxList 'XlsxListコレクション（ブック名）をループ
    Dim wb As Workbook: Set wb = Workbooks.Open(tgtPath & bookName) 'ブックを開く
    
    Dim tgtSheet As Worksheet
    For Each tgtSheet In wb.Worksheets 'シートをループ
      Dim chartCount As Integer: chartCount = 0 'カウントリセット
      
      Dim tgtShape As Shape
      For Each tgtShape In tgtSheet.Shapes 'シェイプをループ
      
        If tgtShape.Type = msoChart Then 'シェイプがグラフだったときのみ
          tgtShape.CopyPicture xlScreen, xlPicture 'クリップボードにコピー
          Dim ppSld As Object 'スライド用変数
          If chartCount = 0 Then 'そのシートではじめてだったら
            Set ppSld = pp.Slides.Add(Index:=pp.Slides.Count + 1, Layout:=12) 'スライドを追加して指定（定数12=ppLayoutBlank）
          Else
            Set ppSld = pp.Slides(pp.Slides.Count) 'それ以外は最終スライドを指定
          End If
          ppSld.Shapes.Paste '貼り付け
          chartCount = chartCount + 1 'カウントアップ
        
          '位置・サイズを補正
          With ppSld.Shapes(ppSld.Shapes.Count) '最終シェイプを指定
            .LockAspectRatio = msoTrue '縦横比固定
            .top = 50 * chartCount '上からの位置
            .left = 50 * chartCount '左からの位置
            .width = 500 '横幅
          End With
        End If
        
      Next 'シェイプのループ終点
      
      If chartCount <> 0 Then 'コピーしたものがあったら
        'ブック名 & シート名をテキストボックスで挿入
        pp.Slides(pp.Slides.Count).Shapes.AddTextbox( _
          Orientation:=msoTextOrientationHorizontal, _
          left:=0, _
          top:=0, _
          width:=200, _
          Height:=40) _
          .TextFrame.TextRange.Text = bookName & " " & tgtSheet.Name
      End If
    Next 'シートのループ終点
    
    wb.Close 'ブックを閉じる
  Next 'XlsxListコレクション（ブック名）のループ終点
  
TERMINATE:
  On Error GoTo 0
  Set pp = Nothing
  Set ppSld = Nothing
  Exit Sub
 
ERROR_HANDLER:
  MsgBox Err.Description, vbCritical
  Resume TERMINATE
End Sub

コードにウザいくらいコメントつけてあるのでこれ以上書くこともないのですが…、いったんフォルダ内のxlsxファイル名をコレクションに格納して、それをもとにブックをループでまわして、そのなかのシートもループして、シートごとにすべてのシェイプをループでまわして、もしグラフ（Chart）だったらコピペして、という感じです。

カスタマイズすれば、1グラフ1スライドにも1ブック1スライドにもできるし、グラフだけじゃなくて図形なんかもコピペできます。