[ExcelVBA]PowerPointの指定したスライドへExcelグラフを最背面で貼り付ける

パワポへの貼り付けについての記事、かなり沢山の方にご覧頂いているようで、大変嬉しいです。前に書いたものの派生と言いますか、ちょっと違うアプローチの仕方でのコピペコードのご紹介です。

前に書いた記事

• Excelで作成したグラフ等を自動でPowerPointへ貼り付けるExcelVBA

こちらの記事へ質問を頂きまして、それについて（全部は無理でしたが）なんとかなりそうだったので、記事にしてみました。

目的

既存のpptの指定シートに、Excelの指定グラフをそれぞれ貼り付けるという感じです。

差し替えるということは、新しく貼り付けたグラフを最背面へ移動させて、古いグラフを削除したいということですね。

テキストボックスや図形などが重なったレイアウトのものは面倒なので、Excel上で全部体裁を整えたうえで、pptにはまるっとコピペするだけ簡単！っていうのが前述した記事の概要なんですが、やはりグラフ以外の要素はpptでいじれるようになっていて欲しい（そうせざるを得ない）という方も結構多いんだと思います。

結論から申し上げますと、「古いグラフを削除する」という項目だけは実装できませんでした。。既存のpptファイルの中の、消したいグラフのシェイプ番号が特定できないというのが理由です。

スライドによって番号が違ってきてしまうし、間違って他のシェイプ（テキストボックスとか図形とか）を消してしまっても問題なので、ここだけは手動で消して頂くしかないかなぁというのが、今の私の結論です。どなたか良い方法ありましたら教えてください！

コード

Sub select_CopyToPPT()
  Dim ppApp As Object 'PowerPointアプリ
  Dim ppPst As Object 'PowerPointプレゼン
  Dim ppSld As Object 'PowerPointスライド
  Dim n As Integer, i As Integer, flg As Boolean
  Dim PecNmb As Integer, ShtNam As Variant, GrpNmb As Variant, SldNmb As Variant

  '処理したいExcelグラフの数
  PecNmb = 3
  'コピーしたいExcelグラフが存在するシート名
  ShtNam = Array("sheet1", "sheet2", "sheet3")
  'コピーしたいExcelグラフの名前
  GrpNmb = Array("グラフ 1", "グラフ 2", "グラフ 3")
  '貼り付け先PowerPointのスライド番号
  SldNmb = Array(1, 2, 3)

  On Error GoTo ERROR_HANDLER

  Set ppApp = CreateObject("PowerPoint.Application")
  Set ppPst = ppApp.ActivePresentation

  For n = 0 To PecNmb - 1
    '指定範囲をクリップボードにコピー
    Sheets(ShtNam(n)).ChartObjects(GrpNmb(n)).CopyPicture xlScreen, xlPicture
    'PowerPointスライド指定
    Set ppSld = ppPst.Slides(SldNmb(n))
    '貼り付け
    ppSld.Shapes.Paste

    '最終のシェイプ番号を取得するための数値
    '1シートあたりの既存のシェイプ（TextBoxや図を含む）の最大合計数より大きな数値で指定
    i = 100

    flg = True 'エラー分岐フラグ
lp:
    '位置・サイズを補正
    With ppSld.Shapes(i) 'シェイプが存在しなければエラーへ
      .LockAspectRatio = msoTrue '縦横比固定
      .Top = 100 '上からの位置
      .Left = 60 '左からの位置
      .Width = 600 '横幅
      '.Height = 400 '縦幅（必要な場合は頭の「'」を外して設定）
      .ZOrder msoSendToBack '最背面へ移動
    End With
    flg = False 'フラグリセット
  Next n

TERMINATE:
  On Error GoTo 0
  Set ppApp = Nothing
  Set ppPst = Nothing
  Set ppSld = Nothing
  Exit Sub

ERROR_HANDLER:
  If flg = True Then
    If Err.Number <> 0 Then Resume ERROR_HANDLER 'エラーリセット
    i = i - 1 '存在するシェイプ番号になるまでマイナスする
    GoTo lp
  Else
    MsgBox Err.Description, vbCritical
    Resume TERMINATE
  End If
End Sub

※もっと省コードのやり方を教えて頂けました！解説はこのままにしておきますが、ご使用は追記のコードがお勧めです。

ハイライトしてある部分を変更してお使いください。起動の際には、貼り付け先のPowerPointファイルを開いた状態にしておいてください。

利用時の設定

コピー元、貼り付け先を指定する

例えば、PecNmb=3としたら3回コピペ処理を繰り返すわけですが、

1. 1回目のループは、シート名1のグラフ名1を、スライド番号1へコピペする
2. 2回目のループは、シート名2のグラフ名2を、スライド番号2へコピペする
3. 3回目のループは、シート名3のグラフ名3を、スライド番号3へコピペする

という処理を行います。コピー元のExcelシートが一つで、その中に複数グラフがある場合はシート名は3つとも同じ名前になります。省略することはできませんので、回数分書いてください。

また、シートが違うとグラフ番号がリセットされるため、sheet1のグラフ1とsheet2のグラフ1という場合も有り得ます。この場合、違うグラフであっても指定するグラフ名には同じ文字列が続くことになります。

スライド番号は、表紙を含めた数値になります。

グラフ名の調べ方

白い矢印にしてから、

グラフを選択すると、左上に出てくるのがグラフ名です。

「グラフ_1」のように半角スペースが入っていたりしますので、コピペすると確実です。正しい名前を入力しないとエラーになります。

貼り付け位置、大きさを指定する

図のように設定できますので、お好みの数値を入れてください。グラフの縦横比は固定になっているので横幅だけ設定すれば縦幅は自動ですが、比率を無視して大きさを決めたい場合は42行目から設定してください。

コードの解説

できるだけ汎用的になれば良いなぁと思って配列を使って冒頭で指定してもらって、あとはコピペをループさせる仕組みになっています。

ちょっと悩んだのが、pptに貼り付けした時点でグラフがアクティブ状態にならなかったところ。アクティブになってればそのまま位置・大きさ補正に繋げられたのですが、困ってしまいました。

どうにか考えて、貼り付けたグラフはそのスライドでの最終シェイプ番号になっているだろうと検討をつけ、存在しないであろうシェイプの数値を指定（32行目）してわざとエラーを起こし、存在するシェイプ番号になるまでマイナスしていくというちょっと強引なことをしています。

更にそこで、最終のシェイプ番号が分かれば、-1すればその前に作成されたシェイプになるんじゃね？それをdeleteすれば古いグラフ消せるんじゃね？とも思ったんですが、その番号が必ず消したいグラフの番号とは限らないわけで…やはり断念しました_(┐「ε:)_

と、いう感じで勉強も兼ねて書かせて頂きました。ニッツさん、いかがでしたでしょうか。古いグラフの特定の仕方ものんびり探していければと思っています。

2013/1/13追記：省コードver

コメント欄より、最終シェイプ番号を取得する方法を教えて頂けましたー！これなら、わざとエラーを起こしてループさせるなんて強引な方法を取らずに済みますね。こんなに短くなっちゃいます！

Sub select_CopyToPPT()
  Dim ppApp As Object 'PowerPointアプリ
  Dim ppPst As Object 'PowerPointプレゼン
  Dim ppSld As Object 'PowerPointスライド
  Dim n As Integer
  Dim PecNmb As Integer, ShtNam As Variant, GrpNmb As Variant, SldNmb As Variant

  '処理したいExcelグラフの数
  PecNmb = 3
  'コピーしたいExcelグラフが存在するシート名
  ShtNam = Array("sheet1", "sheet2", "sheet3")
  'コピーしたいExcelグラフの名前
  GrpNmb = Array("グラフ 1", "グラフ 2", "グラフ 3")
  '貼り付け先PowerPointのスライド番号
  SldNmb = Array(1, 2, 3)

  On Error GoTo ERROR_HANDLER

  Set ppApp = CreateObject("PowerPoint.Application")
  Set ppPst = ppApp.ActivePresentation

  For n = 0 To PecNmb - 1
    '指定範囲をクリップボードにコピー
    Sheets(ShtNam(n)).ChartObjects(GrpNmb(n)).CopyPicture xlScreen, xlPicture
    'PowerPointスライド指定
    Set ppSld = ppPst.Slides(SldNmb(n))
    '貼り付け
    ppSld.Shapes.Paste

    '位置・サイズを補正
    With ppSld.Shapes(ppSld.Shapes.Count) '最終シェイプを処理
      .LockAspectRatio = msoTrue '縦横比固定
      .Top = 100 '上からの位置
      .Left = 60 '左からの位置
      .Width = 600 '横幅
      '.Height = 400 '縦幅（必要な場合は頭の「'」を外して設定）
      .ZOrder msoSendToBack '最背面へ移動
    End With
  Next n

TERMINATE:
  On Error GoTo 0
  Set ppApp = Nothing
  Set ppPst = Nothing
  Set ppSld = Nothing
  Exit Sub

ERROR_HANDLER:
  MsgBox Err.Description, vbCritical
  Resume TERMINATE
End Sub

yamaさん、本当にありがとうございました！

2014/8/20追記：古いグラフを削除するver

もしも「このVBAを今後も使用」し、「差し替え対象がこのVBAで貼付けたモノ」だった場合、貼付けた時点で名前を定義してしまえば、その名前のシェイプを指定して削除してやれば良いのでは？と考えました。

定義した名前のシェイプが存在しない場合（初回であったり、手動で削除されていたり）もあるので、スライド内のシェイプ名を全部確かめて、存在したら削除する、という方法にしています。

Sub select_CopyToPPT()
  Dim ppApp As Object 'PowerPointアプリ
  Dim ppPst As Object 'PowerPointプレゼン
  Dim ppSld As Object 'PowerPointスライド
  Dim n As Integer, shp As Object
  Dim PecNmb As Integer, ShtNam As Variant, GrpNmb As Variant, SldNmb As Variant
 
  '処理したいExcelグラフの数
  PecNmb = 3
  'コピーしたいExcelグラフが存在するシート名
  ShtNam = Array("sheet1", "sheet2", "sheet3")
  'コピーしたいExcelグラフの名前
  GrpNmb = Array("グラフ 1", "グラフ 2", "グラフ 3")
  '貼り付け先PowerPointのスライド番号
  SldNmb = Array(1, 2, 3)
 
  On Error GoTo ERROR_HANDLER
  
  Set ppApp = CreateObject("PowerPoint.Application")
  Set ppPst = ppApp.ActivePresentation
 
  For n = 0 To PecNmb - 1
    'PowerPointスライド指定
    Set ppSld = ppPst.Slides(SldNmb(n))
    
    'スライド内のシェイプ名を全部確認
    For Each shp In ppSld.Shapes
      If shp.Name = "target" Then shp.Delete '"target"があったら削除
    Next shp
    
    '指定範囲をクリップボードにコピー
    Sheets(ShtNam(n)).ChartObjects(GrpNmb(n)).Copy
    '貼り付け
    ppSld.Shapes.Paste
    
    '位置・サイズを補正
    With ppSld.Shapes(ppSld.Shapes.Count) '最終シェイプを処理
      .LockAspectRatio = msoTrue '縦横比固定
      .Top = 10 '上からの位置
      .Left = 10 '左からの位置
      .Width = 300 '横幅
      '.Height = 150 '縦幅（必要な場合は頭の「'」を外して設定）
      .ZOrder msoSendToBack '最背面へ移動
      .Name = "target" '名前を定義
    End With
  Next n
 
TERMINATE:
  On Error GoTo 0
  Set ppApp = Nothing
  Set ppPst = Nothing
  Set ppSld = Nothing
  Exit Sub
 
ERROR_HANDLER:
  MsgBox Err.Description, vbCritical
  Resume TERMINATE
End Sub

今回のコードはコピーする部分を.CopyPictureではなく.Copyにしてみたので、グラフなどはそのまま貼付けられる仕様です。（モノによっては重くなるので画像として貼り付けたい方は先述のコードをご参照ください。）

ハイライト部分が、targetという名前のシェイプを削除したり定義したりしている部分です。同名では定義できないので、先に消しておかないといけません。