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

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

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


前に書いた記事

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

目的

121004-1

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

121004-2

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

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

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

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

[2014/8/20追記] 削除方法ひらめきました!これ書いてから2年近く経ってしまっていますが、せっかくなので記事の末尾に追記しておきますー!

コード

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ファイルを開いた状態にしておいてください。

利用時の設定

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

121004-3

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

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

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

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

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

グラフ名の調べ方

121004-4

白い矢印にしてから、

121004-5

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

121004-6

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

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

121004-7

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

コードの解説

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

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

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

ひとつのスライドに既存のシェイプ(テキストボックスとか図形など)が100個以上ある場合は(そんなにないと思うんですがw)、それより大きい数にしてみてください。あんまり大きな数にすると重くなっちゃいますが…。

更にそこで、最終のシェイプ番号が分かれば、-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という名前のシェイプを削除したり定義したりしている部分です。同名では定義できないので、先に消しておかないといけません。

公開日:2012/10/04
更新日:2014/08/20

24件のコメント

  1. ニッツ より:

    youさん、こんなにキレイに分かりやすく説明してもらってどうもありがとうございます!大変感動しました。
    確かに古いグラフだけを消すという特定が難しいですよね・・・。無理なお願いをしてしまい悩ませてすみませんでした。
    でも、その他の作業はやりたかった事にほぼ近いものが出来そうですので、上手くアレンジして使わせて頂きます。
    他にも日々楽にしたいなぁ、という作業が多々ありますが、また機会があれば質問させて頂きたいと思います!
    ホントにありがとうございました!

    • you より:

      ニッツさん、フィードバックありがとうございます。
      ご要望に沿ったことができたか不安だったんですが、多少なりともお役に立てたようで何よりです。私も今回のことでいろいろ勉強になりました。
      VBAでの効率化、ハマるととっても面白くなってきますよね。是非がんばってください!

  2. yama より:

    非常にわかりやすいコードで参考になりました。パワポに貼り付ける仕事は多いので重宝します。

    最終のシェープ番号をとるところですが、スライドにグラフを貼り付けた直後に「スライド内に何個シェープがあるか」を数えるととれるようです。このコードでいうと、
    With ppSld.Shapes(i)

    With ppSld.Shapes(ppSld.Shapes.Count)
    とすればできると思います。

    • *you より:

      yamaさん、コメントありがとうございます。
      ppSld.Shapes.Count…!なるほどそんな方法が…!
      早速記事に追記させて頂きました、本当にありがとうございました!

  3. のんびり より:

    Excelの(グラフではなく)セルの表をそのままPPTの既存スライドに埋め込んでいくにはどうしたらいいのでしょうか? 知っていたら教えてください。よろしくお願いいたします。

    • *you より:

      のんびり さん、コメントありがとうございます。
      追記(省コードver)のほうのコードを以下のように差し替えてみてください。

      6行目
      GrpNmb As Variant
        ↓
      Rng As Variant
      
      13行目
      GrpNmb = Array("グラフ 1", "グラフ 2", "グラフ 3")
        ↓
      Rng = Array("範囲1", "範囲2", "範囲3")
      
      24行目
      Sheets(ShtNam(n)).ChartObjects(GrpNmb(n)).CopyPicture xlScreen, xlPicture
        ↓
      Sheets(ShtNam(n)).Range(Rng(n)).CopyPicture xlScreen, xlPicture
      

      シート名1の範囲1を、スライド番号1へコピペ(2,3…と続く)というコードになります。範囲は"A1:G10"のように指定してください。

  4. のんびり より:

    早急な回答ありがとうございます。いわれてたとおりにいれてみたのですが、型が一致しませんと出てしまいます。何が原因かわかりますか?

    • *you より:

      すみません、さすがにそれだけではなんとも…。

      先ほど本文にそのまま書いたらダブルクォーテーション等が全角などに整形されてしまっていたようなので、書き直しました。もう一度追記のほうのコードコピーから試してみて頂けますか。

      まるごとコピーの際は、コードへマウスを乗せたときに右上に出てくるアイコンの左から2番目の「クリップボードのコピー」で、差し替えのときは1番左のアイコンで「ソースを表示」してから該当部分だけコピーして頂けると間違いがないかと思います。

      現在ではそのまま選択してコピーできる仕様になっています。

  5. のんびり より:

    丁寧な回答ありがとうございました。
    もう一度組みなおしたところ成功しました!(^^)!
    どこか文字が間違っていたみたいです(汗)
    VBAをちゃんと勉強してみたくなりました★本当にありがとうございます。

    • *you より:

      わぁ、よかったです!(*´∀`*)
      一文字でも違ってたりするとうまく走らなかったりするので、慣れるまではちょっと難しいですよね。
      でも興味を持って頂けて嬉しいですー!

  6. のんびり より:

    昨日はとても助かりました。
    PPとExcelの連携をよく使用するのですが、その連携が詳しく書かれている本をご存じですか? もし、知っていれば教えてください。 Excelだけのものばかりでなかなか連携がのっている本がみつかりません。。。よろしくお願いいたします。

    • *you より:

      連携に関する書籍となるとちょっと難しいですね。そもそもPowerPointVBAの書籍自体も少ない印象なので…。私はPowerPointVBAは全然触ったことがありませんが、

      こちらのサイトや、PowerPointのマクロの記録機能を使ってコードを拾って、それを検証してみるしかないのかなぁと、個人的には思います。

  7. kerotan より:

    ExcelVBAで作成した100個以上のシート埋め込みグラフをPowerPointへ貼り付ける手作業は苦痛の何物でもありませんでした。ご紹介頂いたコード本当にありがたいです。公開ありがとうございました。

    • *you より:

      kerotanさん、コメントありがとうございます!
      手作業のコピペ作業ほんとに辛いですよね(私も新人の頃やってました)…!お役に立てて光栄ですー(*´∀`*)

  8. pepe より:

    このマクロのおかげでいろいろと捗りそうです。
    ありがとうございます。

    画像としてコピペするのでは無く、表としてそのままコピーさせるにはコードをどう変更すればよいか、ご存じでしたらご教授のほどお願いいたします。

    CopyやらSpecialPasteやら試してみたのですが、エラーを吐いてうまくいかず・・・orz

    • *you より:

      pepeさんコメントありがとうございます。お役に立てて光栄です!

      過去に書いた、こちらの記事が参考になるかもしれません。Office2013で検証しています。

      Officeのバージョンによって動作が違う可能性もあるのでご期待に添えられるかは分かりませんが、ご参考になれば。

      追記:すみません、面倒なことをせずとも.CopyPicture xlScreen, xlPicture.Copyにするだけで良かったです!

  9. やまだのこ より:

    *youさん
    お世話になっております。
    度々すみません、次はこちらに関して質問させていただきます。。

    のんびりさんとのやりとりをもとにグラフではなく範囲指定に変えて表の貼り付けをやってみました。
    横長の表なので、縦横比固定を外した上で、Widthを変えて調整しようとしたのですが、何度やっても長さを変えられず、スライド内におさめられず・・

    他にどこを変える必要があるかご教示いただけませんでしょうか。

    よろしくおねがいいたします。。

    • *you より:

      やまだのこ さん、コメントありがとうございます。

      「何度やっても長さを変えられず、スライド内におさめられず」の部分をもうちょっと具体的にお願いします。エラーが出るのか、出るならば、どこでなんというエラーが出るのか、エラーが出ないままプロシージャが最後まで実行されるのかなどで、変わってきます。

      こちらの記事にもあるように、OSの違いやOfficeのバージョンによっても違う挙動を見せる場合があります。

      また、こちらの記事でもセル範囲で表を指定してコピペできるコードを紹介しています。クラスを使いますが、こちらのほうがコードとしてはスマートですのでよかったらお試しください。

  10. やまだのこ より:

    *youさん
    早速アドバイス頂きましたのに御礼が遅くなり申し訳ありませんでした。
    エラーは出なかったのですが、縦横比が固定されていたように見えたので、ご質問させて頂きました。縦横比固定解除は行を削除したらよいんだろうととんだ勘違いをしていたのですが、別の資料で.LockAspectRatio = msoFalse にすればよいことを知りました。。お手数をおかけしました。

    • *you より:

      そういうことでしたか、解決して何よりです。こちらには原因というのは非常に推測しづらいものですので、ご自分での解決がいちばん近道です!

  11. より:

    Excelのグラフではなく画像をPwerPointに貼り付ける場合はどのように修正したらよろしいでしょうか?
    お手数ですがご教授頂けますようお願いいたします。

    • *you より:

      洋さん、コメントありがとうございます。
      追記(省コードver)のほうのコードを以下のように差し替えてみてください。

      6行目
      GrpNmb As Variant
        ↓
      ImgNmb As Variant
      
      13行目
      GrpNmb = Array("グラフ 1", "グラフ 2", "グラフ 3")
        ↓
      ImgNmb = Array("図 1", "図 2", "図 3")
      
      24行目
      Sheets(ShtNam(n)).ChartObjects(GrpNmb(n)).CopyPicture xlScreen, xlPicture
        ↓
      Sheets(ShtNam(n)).Shapes(ImgNmb(n)).Copy
      

      シート名1の図 1を、スライド番号1へコピペ(2,3…と続く)というコードになります。

  12. より:

    youさん
    お返事ありがとうございました。
    無事貼り付けることができました。
    excelとパワポをどう連携すればいいか困っていたのですごく助かりました。
    本当にありがとうございました。

    • *you より:

      洋さんフィードバックありがとうございます! 無事動いてなによりですー(*゚ω゚*)


コメントを残す

メールアドレスが公開されることはありません。 が付いている欄は必須項目です

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください

コメントは承認制ですので、反映までしばらくお待ち下さい。(稀にスパムの誤判定にて届かないこともあるようですので、必要な際はお問い合わせからお願い致します。)

YouTubeでQ&Aコンテンツを企画しています

運営しているYouTubeチャンネルで、ご相談やご質問を募集しています。動画のコメントやお問い合わせページからお気軽にご相談をお寄せください。