ExcelVBAを使ってグラフや図表をPowerPointにペーストする

筆者の職場のリーダーさんからの依頼で、彼らが日々Excelで作成している図表やグラフをマクロでPowerPointに貼り付け⇒報告書作成の手間を軽減してほしいとのこと。
例によって、ネット情報をもとにいろいろ試行錯誤して得られたTipsなどを記します。

実際にはOracleや外部ファイルからAccessにデータ引き込んで加工・集計し、それをExcelで取り込んで・・・という仰々しい？仕組みの一環なんですが、分かりやすさと守秘義務の関係で簡潔な内容に編集しております

---

1. 下準備

1) 表のテーブル化＆名前付け

Excelでは、Accessのテーブルなど外部データの内容をワークシートに展開すると、おのずと表はテーブルとして定義されます。
ただ、それ以外に作成した表についても、あらかじめテーブル形式に変換しておくとデザイン的にも統一感があるし、何より後々扱いが楽です。

2) グラフへの名前付け

こちらも後々扱いが楽になるよう、グラフにも名前を定義しておきます。
こちらは、グラフエリアを選択した状態で画面左上の欄に名前を指定すればOKです。

3) PowerPointを参照設定

ExcelのVisual Basic Editorの参照設定で
"Microsoft PowerPoint xx.xx Object Library"
にチェックを入れます。

・Excel-PowerPoint間のAPIがないそうで、下記コーディング例の通り、ひたすらコピー＆ペースト・・・という泥臭い処理内容になっております・・・
・ExcelからPowerPointに図表を貼り付ける処理自体がかなり重いので、ここではアーリーバインディングを使います。

---

2. 実際の処理

ここでは、あらかじめ用意しておいたPowerPointのひな形ファイルの所定の位置に、Excelの表やグラフをコピー⇒貼り付けして別名保存する例です。

1) 初期設定

    ' ひな形のPowerPointファイルを指定するダイアログを表示
    Dim スライドパス As String
    スライドパス = Application.GetSaveAsFilename( _
        InitialFileName:=CurDir(), _
        filefilter:="PowerPointスライドファイル (*.pptx), *pptx", _
        Title:="ひな形スライドファイルを選択してください", _
        buttontext:="指定")
    If スライドパス = "False" Then Exit Sub
    
    ' PowerPoint関連のオブジェクト定義－pPtが上記で指定したPowerPointファイルを指す
    Dim pAp As New PowerPoint.Application
    Dim pPt As Presentation
    Dim pSl As Slide
    Dim pSp As PowerPoint.Shape
    Set pPt = pAp.Presentations.Open(スライドパス)
    
    ' ExcelVBAを実行する際のお約束
    Application.Visible = True
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

2) よくあるパターンの処理

グラフや図表貼り付けの具体例です。

    ' スライド１枚目に対する処理    Set pSl = pPt.Slides(1)
    ' PowerPointのテキストラベル（「作成年月日」で名前定義済）の内容更新
    qSl.Shapes("作成年月日").TextFlame.TextRange.Text = Format$(Date, "yyyy年mm月dd日")
    
    ' スライド３枚目に対する処理
    Set pSl = pPt.Slides(3)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("作業_グラフ")
    
    ' Excel「作業_グラフ」シート上のグラフ「作業_月別対応件数_グラフ」をコピー、ひな形の所定の位置に貼り付け
    ws.ChartObjects("作業_月別対応件数_グラフ").Chart.CopyPicture xlScreen, xlPicture
    pSl.Shapes.Paste
    Set pSp = pSl.Shapes(pSl.Shapes.Count)
    With pSp                            ' 以下、Top/Left/Widthの値はcm/0.035(pt)の値を指定
        .Top = 48.57                    ' 縦位置
        .Left = 7.43                    ' 横位置
        .LockAspectRatio = msoTrue      ' 縦横比を固定
        .Width = 714.29                 ' 幅
    End With
    
    ' 固定票（レイアウトが固定）「作業_月別対応件数_表」をコピー⇒貼り付け
    ws.Range("作業_月別対応件数_表").Copy
    pSl.Shapes.PasteSpecial DataType:=PoPasteEnhanceMetafile, Link:=msoFalse
    Set pSp = pSl.Shapes(pSl.Shapes.Count)
    With pSp
        .Top = 409.43
        .Left = 0
        .LockAspectRatio = msoTrue
        .Width = 714.29
    End With
    
    Set pSl = pPt.Slides(4)
    Set ws = ThisWorkbook.Worksheets("作業内容_詳細")
    ' 可変表（データによって行数が変わる）「作業_時間外案件_表」をコピー⇒貼り付け
    ' （"CurrentRegion.Copy"で、定義済テーブルを丸ごとコピーしています）
    ws.Range("作業_時間外案件_表").CurrentRegion.Copy
    pSl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile, Link:=msoFalse
    Set pSp = pSl.Shapes(pSl.Shapes.Count)
    With pSp
        .Top = 124.86
        .Left = 0
        .LockAspectRatio = msoTrue
        .Width = 714.29
    End With
    
    Application.CutCopyMode = False
    
    ' コピー先PowerPointファイルに名前を付けて保存
    pPt.SaveAs CurDir & "\月次報告書_" & Format$(Now(), "yyyymmd") & ".pptx"
    pAp.Quit
    Set pSl = Nothing
    Set pPt = Nothing
    Set pAp = Nothing
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "月次報告書への図表の貼り付けが完了しました", vbInformation + vbOKOnly, "お知らせ"

3) ちょっと凝った制御

例えばデータによって行数が変わる可変表のとき、データがない場合は該当の表をコピーせずにその旨メッセージ表示する・・・などの制御が必要になる場合があります。

①まず、該当表の行の増減に影響のないセルに、次のようにCOUNTA関数を埋め込みます。
　表の中で必ずデータが入るカラムを対象にカウントし、このセルにも名前を付けます。

②VBAでは、まず①で定義した表の件数を参照して、行があった時は表をコピーします。　行がなかったときは、その旨を記したテキストラベルを新規に作成します。

    If Not IsEmpty(ws.Range("作業_時間外件数")) And _
       IsNumeric(ws.Range("作業_時間外件数").Value) And _
       ws.Range("作業_時間外件数").Value > 0 Then
        ' 可変表をコピー
        ws.Range("作業_時間外件数_表").CurrentRegion.Copy
        pSl.ShapesPasteSpecial DataType:=ppPasteDefault, Link:=msoFalse
        Set pSp = pSl.Shapes(pSl.Shapes.Count)
        With pSp
            .Top = 87.43
            .Left = 0
            .LockAspectRatio = msoTrue
            .Width = 714.29
        End With
    Else
        ' テキストラベルを追加する
        With pSl.Shapes.AddTextbox(OrientationHorizontal, Left:=285.71, Top:=138, Width:=600, Height:=200)
            .TextFrame.TextRange.Text = "該当案件なし"
            .TextFrame.TextRange.Font.Size = 20
        End With
    End If