VBAでExcelのグラフをパワーポイントに貼り付ける！

お疲れ様です、しるるです！

毎月毎月、偉い人から「このデータグラフにしてパワーポイントでちょーだい！」って言われて資料を作っているのですが、なんだかどんどんどんどんほしいものが増えてきて、もう貼り付けるのだるいよパトラッシュ…

ってなったのでようやくVBAで貼り付けるようにしました。

使ってみたらかなり快適になったので共有します。

私の作成したものは、Excelシートの一番右のシートから順番に、パワーポイントに貼り付けていくものです。Excelの1つのシートに1つのグラフじゃないとエラーになるので注意してください。完成後、pptchartというパワポが同じところに保存されます。

予め用意するもの

1/8追記
・参照設定でMicrosoft PowerPoint 16.0 Object Libraryのライブラリにチェックを入れてください！

・テンプレートのパワーポイントを作成して、Excelと同じところに保存してください！ファイル名は template、拡張子はpptxで。ファイル名を変えたい場合は、コードの中身のファイル名もいじってくださいね！

・スライドのタイトルをシートのA1に入力する

こんな感じで1枚ずつ貼り付けていきます。

貼り付けて位置調整して、サイズ調整してってめっちゃめんどくさいよね…

ほんとめんどくさすぎてしんどい…枚数増えれば増えるほどしんどいんじゃあああ！！！！

コード

Option Explicit
Sub ppt_chart()
   Dim ws As Worksheet
   Dim str As String
   Dim numSh As Long, c As Long

   Set ws = ActiveSheet

   'パワーポイントを立ち上げる
   Dim ppApp As New PowerPoint.Application
   ppApp.Visible = True

   '予め用意したtemplate.pptxを立ち上げる
   Dim pptx As PowerPoint.Presentation
   Set pptx = ppApp.Presentations.Open(ThisWorkbook.Path & "\template.pptx")

   Dim pptxsl As PowerPoint.Slide
   Set pptxsl = pptx.Slides(1)

   'タイトルのフォントサイズを変更(お好みで）
   If pptxsl.Shapes.HasTitle Then
       pptxsl.Shapes.title.TextFrame.TextRange.Font.Size = 22
   End If


   'Excelのシート数を調べ、グラフにするシートが左から何枚までか指定する（countShの数値を変更してください）
   Dim countSld As Long, countSh As Long
   numSh = Worksheets.Count
   countSh = 3
   
   '画像サイズの設定（高さと幅の調整してます。お好みで変更してください）
   Dim ppW As Single, ppH As Single
   With pptx.PageSetup
       ppH = .SlideHeight * 0.8
       ppW = .SlideWidth
   End With

   For c = 0 To numSh - countSh
           Worksheets(numSh - c).Activate
           ActiveSheet.ChartObjects.Select
           
           'A1セルの文字をタイトルにする
           str = Worksheets(numSh - c).Range("A1").Value
           
           countSld = pptx.Slides.Count
           '1ページ目をコピーしてスライドの最後に複製
           pptx.Slides(1).Duplicate.MoveTo (countSld + 1)

           'Excelのグラフを画像としてコピーする
           ActiveChart.ChartArea.Copy
           
           'エラー対策のため待機時間を設ける
           Application.Wait Now() + TimeValue("00:00:02")
           
           pptx.Slides(countSld + 1).Select
           'パワポの最後のスライドにグラフを貼り付ける
           pptx.Slides(countSld + 1).Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile, Link:=msoFalse


           '貼り付けたグラフの位置とサイズを変更する
           With pptx.Slides(countSld + 1).Shapes(pptx.Slides(countSld + 1).Shapes.Count)
               .LockAspectRatio = msoFalse
               .Top = 70
               .Left = 0
               .Width = ppW
               .Height = ppH
          End With

           'タイトルを変更する
           pptx.Slides(countSld + 1).Shapes.title.TextFrame.TextRange.Text = str

   Next

   'パワーポイントファイルを「pptchart」というファイル名で新しく保存する
   pptx.SaveAs ThisWorkbook.Path & "\pptchart.pptx"
   ppApp.Quit
   Set ppApp = Nothing
End Sub