[[20240428172444]]　『ExcelグラフのPPT貼付けマクロ 　汎用性あるコーメx（ぷりん）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

　

『ExcelグラフのPPT貼付けマクロ 　汎用性あるコードに改修したい』（ぷりん）

表題の件、アドバイスお願いします。
Excelのグラフ(オブジェクト名は「グラフ2」）をPPTの指定ページに貼り付ける工程を自動化したいです。

1.のコードは、マクロコードを記載しているファイルの「設定」シートに、 貼付け元のExcel_パス、Excel_シート名、PPT_パス、PPT更新ページ、グラフ貼付け時の位置縦 (cm)、位置横 (cm)、サイズ縦 (cm)、サイズ横 (cm)、グラフのオブジェクト名を書き込んで（B3セル〜B11セルまで）、そのセルを参照してグラフ転記を行ったものになります。
これで正しく動いています。

今回やりたいのは、Excelのセル上に必要情報を記載するのではなく、マクロのコード内にCallの引数としてこれら条件を設定したいです。
（1. のやり方でいいのかもしれませんが、汎用できるコードの書き方の勉強中のため、色々やり方を模索しています）

そこで、2.を作ってみたのですが、これだとExcelパスやシート名、PPTパスがコードのどこに書いてあるか分かりづらいため、

3.を作ってみました。
一応、1, 2, 3どれも思い通りの結果にはなりますが、
どのように書けば使いまわしのきくものになるのか知りたいです。

引数等を使った経験がなく、使い方や使いどころがいまいち分かっていないため、ご教授いただきたく投稿しました。

1, 2, 3に関わらず、他にもシンプルなコードの書き方がありましたらアドバイスいただけますと嬉しいです。

<1のコード＞
Sub ExcelグラフのPPT転記()

    Dim 設定ws As Worksheet
    Dim Excel_パス As String
    Dim Excel_シート名 As String
    Dim PPT_パス As String
    Dim 元Excel As Worksheet
    Dim ppApp As Object
    Dim ppPres As Object
    Dim ppSlide As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape
    Dim 更新ページ As Long
    Dim 位置縦 As Double
    Dim 位置横 As Double
    Dim サイズ縦 As Double
    Dim サイズ横 As Double
    Dim オブジェクト名 As String

    Application.ScreenUpdating = False  '画面の更新の停止
    Set 設定ws = ThisWorkbook.Worksheets("設定")

    '元Excelファイルを開く
    Excel_パス = 設定ws.Range("B3").Value
    Excel_シート名 = 設定ws.Range("B4").Value
    Set 元Excel = Workbooks.Open(Excel_パス).Worksheets(Excel_シート名)

    '更新先パワーポイントを開く
    PPT_パス = 設定ws.Range("B5").Value
    更新ページ = 設定ws.Range("B6").Value
    Set ppApp = CreateObject("powerpoint.application")
    Set ppPres = ppApp.Presentations.Open(PPT_パス)
    Set ppSlide = ppPres.Slides(更新ページ)

    'グラフの貼付け位置とサイズを設定
    位置縦 = 設定ws.Range("B7").Value
    位置横 = 設定ws.Range("B8").Value
    サイズ縦 = 設定ws.Range("B9").Value
    サイズ横 = 設定ws.Range("B10").Value

    'グラフのオブジェクト名を設定
    オブジェクト名 = 設定ws.Range("B11").Value

    'パワーポイントに前回貼付けのグラフが残っていたら削除
    On Error Resume Next
    ppSlide.Shapes(オブジェクト名).Delete
    On Error GoTo 0

    'ExcelのグラフをPPTに貼付け
    元Excel.ChartObjects(オブジェクト名).Copy
    ppSlide.Shapes.PasteSpecial DataType:=ppPasteShape, Link:=msoFalse

    '表示スライドに貼り付けたグラフオブジェクトを再取得
    Set ppShape = ppSlide.Shapes(ppSlide.Shapes.Count)

    'グラフサイズ・位置変更
    'PowerPointマクロ上での長さ（pixel）とcmを換算 ((cmでの長さ)　×　72　/　2.54)
    ppShape.LockAspectRatio = msoFalse  'アスペクト比を固定しない
    ppShape.Top = 位置縦 * 72 / 2.54
    ppShape.Left = 位置横 * 72 / 2.54
    ppShape.Height = サイズ縦 * 72 / 2.54
    ppShape.Width = サイズ横 * 72 / 2.54

    'Excelファイルは保存しないで閉じる
    元Excel.Parent.Close savechanges:=False

    Application.ScreenUpdating = True  '画面の更新の再開

    'パワーポイントを保存して閉じる
    ppPres.Save
    ppPres.Close ' プレゼンテーションを閉じる
    ppApp.Quit ' PowerPoint アプリケーションを終了する

    'オブジェクトを解放する
    Set ppShape = Nothing
    Set ppSlide = Nothing
    Set ppPres = Nothing
    Set ppApp = Nothing   

End Sub

<2のコード＞
Sub グラフ貼付け()

    Call ExcelグラフのPPT転記(2, 2.55, 7.65, 8.25, 16.55, "グラフ2")
End Sub

Sub ExcelグラフのPPT転記(更新ページ As Long, 位置縦 As Double, 位置横 As Double, サイズ縦 As Double, サイズ横 As Double, オブジェクト名 As String)

    Dim Excel_パス As String
    Dim Excel_シート名 As String
    Dim PPT_パス As String
    Dim 元Excel As Worksheet
    Dim ppApp As Object
    Dim ppPres As Object
    Dim ppSlide As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape

    Application.ScreenUpdating = False  '画面の更新の停止

    '元Excelファイルを開く
    Excel_パス = "C:\Users\user\Desktop\諸々\PPT転記\Excel.xlsx"
    Excel_シート名 = "Sheet1"
    Set 元Excel = Workbooks.Open(Excel_パス).Worksheets(Excel_シート名)

    '更新先パワーポイントを開く
    PPT_パス = "C:\Users\user\Desktop\諸々\PPT転記\PPT.pptx"
    Set ppApp = CreateObject("powerpoint.application")
    Set ppPres = ppApp.Presentations.Open(PPT_パス)
    Set ppSlide = ppPres.Slides(更新ページ)

    'パワーポイントに前回貼付けのグラフが残っていたら削除
    On Error Resume Next
    ppSlide.Shapes(オブジェクト名).Delete
    On Error GoTo 0

    'ExcelのグラフをPPTに貼付け
    元Excel.ChartObjects(オブジェクト名).Copy
    ppSlide.Shapes.PasteSpecial DataType:=ppPasteShape, Link:=msoFalse

    '表示スライドに貼り付けたグラフオブジェクトを再取得
    Set ppShape = ppSlide.Shapes(ppSlide.Shapes.Count)

    'グラフサイズ・位置変更
    'PowerPointマクロ上での長さ（pixel）とcmを換算 ((cmでの長さ)　×　72　/　2.54)
    ppShape.LockAspectRatio = msoFalse  'アスペクト比を固定しない
    ppShape.Top = 位置縦 * 72 / 2.54
    ppShape.Left = 位置横 * 72 / 2.54
    ppShape.Height = サイズ縦 * 72 / 2.54
    ppShape.Width = サイズ横 * 72 / 2.54

    'Excelファイルは保存しないで閉じる
    元Excel.Parent.Close savechanges:=False

    Application.ScreenUpdating = True  '画面の更新の再開

    'パワーポイントを保存して閉じる
    ppPres.Save
    ppPres.Close ' プレゼンテーションを閉じる
    ppApp.Quit ' PowerPoint アプリケーションを終了する

    'オブジェクトを解放する
    Set ppShape = Nothing
    Set ppSlide = Nothing
    Set ppPres = Nothing
    Set ppApp = Nothing   
End Sub

<3のコード＞
Sub ExcelグラフのPPT貼付け()

    Dim ExcelPath As String
    Dim ExcelSheetName As String
    Dim PPTPath As String

    ' Excelファイルのパス、シート名、PPTファイルのパスを指定
    ExcelPath = "C:\Users\user\Desktop\諸々\PPT転記\Excel.xlsx"
    ExcelSheetName = "Sheet1"
    PPTPath = "C:\Users\user\Desktop\諸々\PPT転記\PPT.pptx"

    Call ExcelグラフのPPT転記(ExcelPath, ExcelSheetName, PPTPath, 2, 2.55, 7.65, 8.25, 16.55, "グラフ2")
End Sub

Sub ExcelグラフのPPT転記(ExcelPath As String, ExcelSheetName As String, PPTPath As String, 更新ページ As Long, 位置縦 As Double, 位置横 As Double, サイズ縦 As Double, サイズ横 As Double, オブジェクト名 As String)

    Dim 元Excel As Worksheet
    Dim ppApp As Object
    Dim ppPres As Object
    Dim ppSlide As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape

    Application.ScreenUpdating = False  '画面の更新の停止

    '元Excelファイルを開く
    Set 元Excel = Workbooks.Open(ExcelPath).Worksheets(ExcelSheetName)

    '更新先パワーポイントを開く
    Set ppApp = CreateObject("powerpoint.application")
    Set ppPres = ppApp.Presentations.Open(PPTPath)
    Set ppSlide = ppPres.Slides(更新ページ)

    'パワーポイントに前回貼付けのグラフが残っていたら削除
    On Error Resume Next
    ppSlide.Shapes(オブジェクト名).Delete
    On Error GoTo 0

    'ExcelのグラフをPPTに貼付け
    元Excel.ChartObjects(オブジェクト名).Copy
    ppSlide.Shapes.PasteSpecial DataType:=ppPasteShape, Link:=msoFalse

    '表示スライドに貼り付けたグラフオブジェクトを再取得
    Set ppShape = ppSlide.Shapes(ppSlide.Shapes.Count)

    'グラフサイズ・位置変更
    'PowerPointマクロ上での長さ（pixel）とcmを換算 ((cmでの長さ)　×　72　/　2.54)
    ppShape.LockAspectRatio = msoFalse  'アスペクト比を固定しない
    ppShape.Top = 位置縦 * 72 / 2.54
    ppShape.Left = 位置横 * 72 / 2.54
    ppShape.Height = サイズ縦 * 72 / 2.54
    ppShape.Width = サイズ横 * 72 / 2.54

    'Excelファイルは保存しないで閉じる
    元Excel.Parent.Close savechanges:=False

    Application.ScreenUpdating = True  '画面の更新の再開

    'パワーポイントを保存して閉じる
    ppPres.Save
    ppPres.Close ' プレゼンテーションを閉じる
    ppApp.Quit ' PowerPoint アプリケーションを終了する

    'オブジェクトを解放する
    Set ppShape = Nothing
    Set ppSlide = Nothing
    Set ppPres = Nothing
    Set ppApp = Nothing   
End Sub

＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞

---

 グラフは一つではなく、複数あるわけですよね。
 汎用性があるかどうか不明ですが、私ならデータはシートに書きます。
 ・データは横一行に作成します。
 ・グラフを指定するfunction procedureは、"行"番号だけ指定する方式にします。
 （セル参照はCells(r,c)方式にします。）
 （縦書きのほうが慣れているなら、"列"でも問題ありませんが）
 こんな考え方もあるんじゃないでしょうか。一つの意見として参考に。

 なお、シートは汎用の記憶場所ですから、なんらかのエラーに対する障害耐性もあります。
 マイクロソフトは堅牢な変数として、シートに保持することを薦めています。

（xyz） 2024/04/29(月) 07:49:59

---

xyz様
大変貴重なアドバイス、ありがとうございます。

はい、実際はグラフは複数あるものに対応させたいです。

例えば、<3のコード＞で、Callを2行にして

 Call ExcelグラフのPPT転記(ExcelPath, ExcelSheetName, PPTPath, 2, 2.55, 7.65, 8.25, 16.55, "グラフ2")
 Call ExcelグラフのPPT転記(ExcelPath, ExcelSheetName, PPTPath, 3, 5.55, 8.65, 7.25, 10.55, "グラフ1")
のようにしても、動きましたが、これだとパワポをその都度開いて処理して、閉じて、また次のCallへ…となってしまう事にコメント頂いて気づきました。。（Excelのパスやシートも1つしか書けないので、やはりシートに記載した方が良いですね。

function procedureは、"行"番号だけ指定する方式とは、具体的にどのようなコードになりますか？

（ぷりん） 2024/04/29(月) 09:36:01

---

 呼ぶ側は行だけを引数にして、呼ばれた側でそれをもとにシートにアクセスするという意味でした。
 もし不明でしたら却下ください。

（xyz） 2024/04/29(月) 10:20:13

---

xyz様、ありがとうございます。理解しました。
確かに、Excelのセルに条件を書き出して、対応する行をCallで呼んだ方がシンプルで汎用性ききそうですね。

それを分かった上で恐縮ですが、朝の自分のやり方でどうしてもやってみたい事が実現できずアドバイス頂きたく、分かる方いらっしゃいましたら教えてください。

全体の構成を整理しなおしてみました。
下記のようにしたいのですが、どのように引数に設定したりファイル間の引き渡しをすればよいのか分からず、苦戦しています。

sub グラフ貼付け
　パワーポイントを開く
　Excelを開く

　Callで引数を設定して処理（引数に設定したいのは→ Excelのシート名,更新ページ,位置縦,位置横,サイズ縦,サイズ横,オブジェクト名)

　※貼付けたいグラフがPPTの複数ページに渡る場合は、Callをその数分書く。

　Excelを閉じる
　PPTを保存して閉じる
　オブジェクトの解放
End sub

Function PPTグラフ貼付け処理( 〜 引数設定〜 ）
　処理：Excelのシートを指定して、そのシートの指定オブジェクト名のグラフを、指定したPPTのページへ貼り付ける(ただし同じオブジェクト名が元からあった場合は元のを消す、グラフの位置やサイズの調整実施
End Function
　

下記に近いのかと思いますが、下記だと、Callで呼ぶたびにファイルを開いて閉じて…の処理が入ってしまうのと、あとは元のグラフが貼ってあるExcelのシートも複数シートに分かれる場合が想定されるため、シート名もCallの引数に渡したいです。
よろしくお願いします。

Sub グラフ貼付け()

    Call ExcelグラフのPPT転記(2, 2.55, 7.65, 8.25, 16.55, "グラフ2")
    Call ExcelグラフのPPT転記(3, 3.55, 8.65, 7.25, 10.55, "グラフ3")
End Sub

Sub ExcelグラフのPPT転記(更新ページ As Long, 位置縦 As Double, 位置横 As Double, サイズ縦 As Double, サイズ横 As Double, オブジェクト名 As String)

    Dim Excel_パス As String
    Dim Excel_シート名 As String
    Dim PPT_パス As String
    Dim 元Excel As Worksheet
    Dim ppApp As Object
    Dim ppPres As Object
    Dim ppSlide As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape

    Application.ScreenUpdating = False  '画面の更新の停止

    '元Excelファイルを開く
    Excel_パス = "C:\Users\user\Desktop\諸々\PPT転記\Excel.xlsx"
    Excel_シート名 = "Sheet1"
    Set 元Excel = Workbooks.Open(Excel_パス).Worksheets(Excel_シート名)

    '更新先パワーポイントを開く
    PPT_パス = "C:\Users\user\Desktop\諸々\PPT転記\PPT.pptx"
    Set ppApp = CreateObject("powerpoint.application")
    Set ppPres = ppApp.Presentations.Open(PPT_パス)
    Set ppSlide = ppPres.Slides(更新ページ)

    'パワーポイントに前回貼付けのグラフが残っていたら削除
    On Error Resume Next
    ppSlide.Shapes(オブジェクト名).Delete
    On Error GoTo 0

    'ExcelのグラフをPPTに貼付け
    元Excel.ChartObjects(オブジェクト名).Copy
    ppSlide.Shapes.PasteSpecial DataType:=ppPasteShape, Link:=msoFalse

    '表示スライドに貼り付けたグラフオブジェクトを再取得
    Set ppShape = ppSlide.Shapes(ppSlide.Shapes.Count)

    'グラフサイズ・位置変更
    'PowerPointマクロ上での長さ（pixel）とcmを換算 ((cmでの長さ)　×　72　/　2.54)
    ppShape.LockAspectRatio = msoFalse  'アスペクト比を固定しない
    ppShape.Top = 位置縦 * 72 / 2.54
    ppShape.Left = 位置横 * 72 / 2.54
    ppShape.Height = サイズ縦 * 72 / 2.54
    ppShape.Width = サイズ横 * 72 / 2.54

    'Excelファイルは保存しないで閉じる
    元Excel.Parent.Close SaveChanges:=False

    Application.ScreenUpdating = True  '画面の更新の再開

    'パワーポイントを保存して閉じる
    ppPres.Save
    ppPres.Close ' プレゼンテーションを閉じる
    ppApp.Quit ' PowerPoint アプリケーションを終了する

    'オブジェクトを解放する
    Set ppShape = Nothing
    Set ppSlide = Nothing
    Set ppPres = Nothing
    Set ppApp = Nothing    
End Sub

（ぷりん） 2024/04/29(月) 18:09:01

---

先ほどご質問させていただいた件、一応できました。
一般的な書き方がよく分かっていませんが、アドバイス等ありましたら引き続きご教授いただけますと幸いです。
xyz様からアドバイス頂きました方法も、並行して挑戦してみたいと思います。

Sub グラフ貼付け()

    Dim Excel_パス As String
    Dim PPT_パス As String
    Dim wb As Workbook
    Dim ppApp As Object

    ' Excel ファイルと PowerPoint ファイルのパスを指定
    Excel_パス = "C:\Users\user\Desktop\諸々\PPT転記\Excel.xlsx"
    PPT_パス = "C:\Users\user\Desktop\諸々\PPT転記\PPT.pptx"

    ' Excel ファイルと PowerPoint アプリケーションを開く
    Set wb = Workbooks.Open(Excel_パス)
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True
    ppApp.Presentations.Open PPT_パス

    ' グラフを貼り付ける処理を呼び出す
     Call PPTグラフ貼付け処理(wb, "Sheet1", 2, 2.55, 7.65, 8.25, 16.55, "グラフ2")
     Call PPTグラフ貼付け処理(wb, "Sheet2", 3, 3.55, 8.65, 7.25, 10.55, "グラフ1")

    ' Excel ファイルを閉じる
    wb.Close SaveChanges:=False

    ' PowerPoint アプリケーションを終了する
    ppApp.ActivePresentation.Save
    ppApp.ActivePresentation.Close
    ppApp.Quit

    ' Excel と PowerPoint のオブジェクトを解放
    Set ppApp = Nothing
    Set objExcel = Nothing
End Sub

Function PPTグラフ貼付け処理(Excel_シート名 As String, _

                            更新ページ As Long, 位置縦 As Double, _
                            位置横 As Double, サイズ縦 As Double, _
                            サイズ横 As Double, オブジェクト名 As String)
    Dim 元Excel As Worksheet
    Dim ppApp As Object
    Dim ppSlide As Object
    Dim ppShape As Object

    ' Excel ファイルから指定されたシートを取得
    Set 元Excel = wb.Sheets(Excel_シート名)

    ' PowerPoint アプリケーションを取得
    Set ppApp = GetObject(, "PowerPoint.Application")

    ' PowerPoint の指定ページを取得
    Set ppSlide = ppApp.ActivePresentation.Slides(更新ページ)

    ' パワーポイントに前回貼付けのグラフが残っていたら削除
    On Error Resume Next
    ppSlide.Shapes(オブジェクト名).Delete
    On Error GoTo 0

    ' Excel のグラフを PPT に貼付け
    元Excel.ChartObjects(オブジェクト名).Copy
    ppSlide.Shapes.PasteSpecial DataType:=ppPasteShape, Link:=msoFalse

    ' 貼り付けたグラフオブジェクトを再取得
    Set ppShape = ppSlide.Shapes(ppSlide.Shapes.Count)

    ' グラフサイズ・位置変更
    ppShape.LockAspectRatio = msoFalse
    ppShape.Top = 位置縦 * 72 / 2.54
    ppShape.Left = 位置横 * 72 / 2.54
    ppShape.Height = サイズ縦 * 72 / 2.54
    ppShape.Width = サイズ横 * 72 / 2.54
End Function
（ぷりん） 2024/04/29(月) 20:29:05

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.