|
初心者です。
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
|
|