Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3964 / 76734

←次へ　｜　前へ→


	【78398】グラフを既存PPTに複数貼り付けたい

nao - 16/9/8(木) 17:21 -


	引用なし

	パスワード

初心者です。
ExcelグラフをPPTに貼り付けるのですが、位置やサイズが違うため似たような処理を書かなくては成りません。
↓ですと、上しかループせず2枚のPPTにたくさんグラフが貼り付けられてしまいます。
やりたいのは、PPTのページによってグラフの位置やサイズを変えて貼り付けたいです。位置やサイズの取得は出来ているようです。PPTのページが11ページ、12ページにいってくれません。
どのように書けばいいのかご教示ください。

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
　Dim PecNmb2 As Integer, ShtNam2 As Variant, GrpNmb2 As Variant, SldNmb2 As Variant

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

　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)).Copy
　　'PowerPointスライド指定
　　Set ppSld = ppPst.Slides(SldNmb(n))
　　'貼り付け
　　ppSld.Shapes.Paste

　　'位置・サイズを補正
　　With ppSld.Shapes(ppSld.Shapes.Count) '最終シェイプを処理
　　　'.LockAspectRatio = msoTrue '縦横比固定
　　　.Top = 5.2 * 28.35 '上からの位置
　　　.Left = 0.9 * 28.35 '左からの位置
　　　.Width = 23.64 * 28.35 '横幅
　　　.Height = 10.42 * 28.35 '縦幅
　　　.ZOrder msoSendToBack '最背面へ移動
　　End With
　　flg = False 'フラグリセット
　Next n

　'処理したいExcelグラフの数
　PecNmb2 = 2
　'コピーしたいExcelグラフが存在するシート名
　ShtNam2 = Array("グラフ", "グラフ")
　'コピーしたいExcelグラフの名前
　GrpNmb2 = Array("グラフ 7", "グラフ 8")
　'貼り付け先PowerPointのスライド番号
　SldNmb2 = Array(11, 12)

　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)).Copy
　　'PowerPointスライド指定
　　Set ppSld = ppPst.Slides(SldNmb(n))
　　'貼り付け
　　ppSld.Shapes.Paste

　　'位置・サイズを補正
　　With ppSld.Shapes(ppSld.Shapes.Count) '最終シェイプを処理
　　　'.LockAspectRatio = msoTrue '縦横比固定
　　　.Top = 2.9 * 28.35 '上からの位置
　　　.Left = 0 * 28.35 '左からの位置
　　　.Width = 12.58 * 28.35 '横幅
　　　.Height = 10.85 * 28.35 '縦幅
　　　.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:
　MsgBox Err.Description, vbCritical
　Resume TERMINATE

End Sub

8 hits

▼

【78398】グラフを既存PPTに複数貼り付けたい nao 16/9/8(木) 17:21