Excel VBA質問箱 IV

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

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


773 / 13645 ツリー ←次へ | 前へ→

【78398】グラフを既存PPTに複数貼り付けたい nao 16/9/8(木) 17:21 質問[未読]
【78400】Re:グラフを既存PPTに複数貼り付けたい マナ 16/9/8(木) 23:54 発言[未読]
【78401】Re:グラフを既存PPTに複数貼り付けたい nao 16/9/9(金) 16:09 お礼[未読]
【78402】Re:グラフを既存PPTに複数貼り付けたい マナ 16/9/10(土) 9:55 発言[未読]
【78403】Re:グラフを既存PPTに複数貼り付けたい nao 16/9/12(月) 15:43 お礼[未読]

【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

【78400】Re:グラフを既存PPTに複数貼り付けたい
発言  マナ  - 16/9/8(木) 23:54 -

引用なし
パスワード
   ▼nao さん:

>↓ですと、上しかループせず2枚のPPTにたくさんグラフが貼り付けられてしまいます。


パワーポイントは、まったくわかりませんので、参考程度に。
下のループで、変数名の修正もれがあるような気がします。

【78401】Re:グラフを既存PPTに複数貼り付けたい
お礼  nao  - 16/9/9(金) 16:09 -

引用なし
パスワード
   ▼マナ さん:

有難うございます!
確かに変数もれてました。
ちょっとまだ苦戦してますが配列使ってやってみようと思います。

アドバイス有難うございました!

【78402】Re:グラフを既存PPTに複数貼り付けたい
発言  マナ  - 16/9/10(土) 9:55 -

引用なし
パスワード
   ▼nao さん:

>ちょっとまだ苦戦してますが配列使ってやってみようと思います。

グラフ挿入するsubプロシージャを作成し、
変化する部分は、引数で指定するとよいかもしれません。

【78403】Re:グラフを既存PPTに複数貼り付けたい
お礼  nao  - 16/9/12(月) 15:43 -

引用なし
パスワード
   ▼マナ さん:

有難うございます。

773 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free