パフォーマンスモニタの監視データ(blg)に基づいてPowerPointで報告用のレポートを作成する必要がありました。パフォーマンスログのデータをCSVに変換してExcelに取り込んでグラフを作成し、そのグラフをPowerPointに貼り付ける形で実現しようと考えました。
ここでは、Excelの図表をPowerPointに貼り付ける作業をVBAで実現します。
ちなみにPowerShellでも実現できるのですが2019年時点ではVBAを推奨します。詳細はこちらをご覧ください。
概要
Excel上のグラフや表領域をPowerPointの各スライドに貼り付けるExcel VBAを紹介します。
前提
- パフォーマンスモニタのログファイルをExcelにインポートしてグラフや表を作成する処理については、ここでは扱いません。（別途記事を投稿予定です。）
- Microsoft Excel 2013/PowerPoint2013、Excel 2010/PowerPoint 2010を対象とします。それ以外の環境では動作確認できていません。
- コピー元となるExcelファイルのグラフや表、コピー先となるPowerPointファイル上の表等を事前に用意している前提です。
- 技術検証のためのサンプルであり、業務で使用する場合は適宜変更してください。
考察
検証を通して理解したことや気づいたことです。
- Excel上のグラフオブジェクトは、”Worksheet.ChartObjects(name)”で参照できます。引数にはインデックスか名前を指定できます。Excelでグラフオブジェクト等に名前を設定する場合、[ホーム]タブの[検索と選択]-[オブジェクトの選択と表示]から行います。
- PowerPoint上の表オブジェクトは、”Slide.Shapes(name).Table.Cell(row, col)”で参照できます。同様に名前を設定する場合、[ホーム]タブの[選択]-[オブジェクトの選択と表示]から行います。
- Excelの図表をコピーし、PowerPointに張り付ける場合、Windowsのクリップボードを中継することになります。Excel VBAでブックやシート等のExcel上の操作を行う場合は同期処理（個々の操作が完了してから次の処理に進む）となりますが、Excelからの「クリップボード操作」「PowerPoint操作」は非同期処理（それぞれの操作が完了する前に次の処理に進む）となります。そのため、単純にExcelからコピーしてPowerPointに貼り付けを行うと、Excelからクリップボードへの図表コピーが完了する前に、クリップボードからPowerPointへの貼り付けが開始され、期待した通りに動作しない場合があります。
- 個々の操作が完了したかの確認を行えるAPIは存在せず、独自に回避策の実装が必要となります。一番簡単で確実なのはスリープすることです。ただし、この辺の事象の発生はPowerPointのバージョンで異なりますが、新しいバージョンの方が安定している感がします。
手段 概要 コピー後の待機時間を設ける 確実にコピーが完了できるよう、コピー開始後に所定時間待機する方法です。
待機時間に比例して貼り付けの成功率は上がりますが、トータルの処理時間が長くなります。また、環境や処理対象データによって時間の調整が必要となります。貼り付けをリトライする 貼り付け失敗時に再度貼り付けする方法です。
コピーと貼り付け操作は環境依存のようで、PowerPoint2013では有効でしたが、PowerPoint2010では貼り付け失敗時にコピーデータが失われている状態でありリトライに意味がありませんでした。（コピーからリトライすればいいのかもしれません。）独自に値を設定する
(コピペは断念)貼り付けようとしている値をプログラムで値設定する方法です。
例えば表のセル領域をコピーするのではなく、セル個別の値を取得し、貼り付け先のセル個別に値を設定するイメージです。クリップボードを使わないので確実ですが、コード量が増えることや、複雑な値設定は困難です。 - 待機時間を設ける場合、VBA以外の動作がフリーズしてしまうので、前後にDoEventsを実行しましょう。DoEventsを実行することで、OS側で管理している他のアプリのイベントを処理できます。（DoEventsがないと、スリープしてもクリップボードへのコピーが開始されない可能性があるため。）
- PowerPointへの図の貼り付けのために”CommandBars.ExecuteMso(idMso)”を使用しています。これはリボン等のUI上のコマンドを実行するためのコマンドです。引数(idMso)には様々なものを指定可能であり、詳細はこちらで確認できます。
サンプルの説明
サンプルの構成
今回のサンプルは、VBAを格納するCopyMacro.xlsm、コピー元の図表を格納するグラフテンプレート.xlsx、図表の貼り付け先となるサンプルレポート.pptx、という３つのファイルで構成しています。
CopyMacro.xlsmのVBAを実行すると、グラフテンプレート上の各シートにある図表をコピーし、サンプルレポート上の各スライドに順番に張り付けていきます。本来であれば、数十個の図表をレポートに張り付ける必要があったのですが、今回は検証目的であるため、グラフテンプレート上の３シート分の図表を、サンプルレポートの１０スライドに貼り付けます。（Excelの最初の２つの図表は、PowerPointのスライド２，３に貼り付けます。Excelの３つ目の図表を、PowerPointのスライド４以降に繰り返し貼り付けます。）
これらのファイルはこちらからダウンロードできます。
| ファイル名 | 説明 |
|---|---|
| CopyMacro.xlsm | 下記サンプルコードを含むマクロファイルです。 |
| グラフテンプレート.xlsx | サンプルのグラフと表（コピー元）です。 シート”01″に図表、その元となるデータが”01data”シートに定義されています。同様に、”02″/”02data”, “0X”/”0Xdata”シートを格納します。 コピー元となるグラフ(chart)を識別できるよう、[オブジェクトの選択と表示]を使って各シートの対象グラフに”graph”という名前を設定しています。 |
| サンプルレポート.pptx | サンプルのレポート（コピー先）です。 貼り付け先となる表を識別できるよう、[オブジェクトの選択と表示]を使って各スライドの対象表に”main_table”という名前を設定しています。 |
実行方法
CopyMacro.xlsmを開き、[開発タブ]-[Visual Basic]をクリックします。
起動した[Microsoft Visual Basic for Applications]ウインドウで、再生ボタンをクリックします。
マクロ名でCopyXlsToPptを選択し、[実行]をクリックします。
サンプルプログラム
サンプルプログラムは次の通りです。
- PowerPoint操作、クリップボード操作(DataObject)を行うためにVBAの参照設定でDLLを追加しています。クリップボード操作を行うためのライブラリは参照設定の一覧から選択できないため、”C:\Windows\System32\FM20.dll”を参照しています。
- Sleep関数はkernel32のものを使用しています。（処理時間がかかるDoEventsを繰り返し実行して待機する方法もありますが、今回はSleep関数を使うことにしました。）
- 表領域の貼り付けに関して、PowerPoint2013では”PowerPoint.Application.CommandBars.ExecuteMso”でさくさく貼り付けできたのですが、PowerPoint2010での最初の貼り付けに5秒程かかりました。そのため、PowerPoint2013環境では”PowerPoint.Application.ActiveWindow.View.PasteSpecial”を使用しています。（二つのコマンドで若干貼り付けの書式が違うようですが、そこは割り切りました。）
- グラフ貼り付けで使っているPasteSpecial()のリトライ処理は、PowerPoint2013でしか確認できていません。PowerPoint2010環境では、コピー元が不正となるためリトライしても正常に貼り付けできません。
- PowerPoint系のAPIから返却されるオブジェクトを代入時の型不一致エラーがでる場合があります。返却値を入れるDim宣言では、”Dim shape As PowerPoint.Shape”等のようにPowerPointのクラスであることを宣言した方が安全です。
- PowerPoint張り付き先のグラフ座標はPowerPointで確認した結果を入力できるようcm単位にしています。
- 待ち時間(PHASE_INTERVAL, OPE_INTERVAL, COPY_INTERVAL)は、実行環境や対象ファイルに応じて、適宜調整してください。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | Option Explicit '追加が必要な参照設定([ツール]->[参照設定]): '・"Microsoft PowerPoint XX.X Object Library" ' →PowerPoint操作のため。 '・"Microsoft Forms X.X Object Library"(FM20.dllを参照) ' →クリップボード操作(DataObject)のため。 'コピー元のExcel上の図表識別情報 Const XLS_GRAPH_NAME As String = "graph" Const XLS_COPY_RG As String = "B26:D26" 'コピー先のPowerPoint上の図表識別情報 Const PPT_GRAPH_NAME As String = "main_graph" Const PPT_GRAPH_TOP As Double = 4.98 '[cm] ←PPT上の表記に合わせた Const PPT_GRAPH_LEFT As Double = 2.52 '[cm] ←PPT上の表記に合わせた Const PPT_TABLE_NAME As String = "main_table" Const PPT_TABLE_ROW_IDX As Integer = 2 Const PPT_TABLE_COL_IDX As Integer = 2 'PowerPoint操作時の待機時間 Const PHASE_INTERVAL As Integer = (3 * 1000) '[ms] Const OPE_INTERVAL As Integer = (0.1 * 1000) '[ms] Const COPY_INTERVAL As Integer = (1 * 1000) '[ms] '貼り付け失敗時のリトライ回数 Const RETRY_COUNT As Integer = 3 'Sleep関数を使用するため Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long) 'ExcelからPowerPointに図表をコピーする。 Sub CopyXlsToPpt() Dim myfolder As String myfolder = ThisWorkbook.Path Application.Visible = True Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual Dim ppt As New PowerPoint.Application ppt.Visible = msoTrue Dim pres As PowerPoint.Presentation Set pres = ppt.Presentations.Open(myfolder & "\サンプルレポート.pptx", msoFalse) Dim book As Workbook Set book = Workbooks.Open(myfolder & "\グラフテンプレート.xlsx", 0, True) '起動が確実に完了後から処理開始 WaitPhaseInterval Dim st As Worksheet Dim sl As PowerPoint.slide '項目A **************************************** Set st = book.Sheets("01") Set sl = pres.Slides(2) sl.Select 'コピー先が表示されている必要あり(80048240エラー回避) CopyTable st, ppt, sl CopyGraph st, sl '項目B **************************************** Set st = book.Sheets("02") Set sl = pres.Slides(3) sl.Select CopyTable st, ppt, sl CopyGraph st, sl '項目X(テスト用繰り返し) ********************** Dim i As Integer For i = 4 To 10 Set st = book.Sheets("0X") Set sl = pres.Slides(i) sl.Select CopyTable st, ppt, sl CopyGraph st, sl Next 'コピー前にExcelが終了しないよう待機 '(意図しない形式で貼り付けされる場合があるため。) WaitPhaseInterval book.Close 'pres.Close 'ppt.Quit End Sub '表データをコピーする。 Sub CopyTable(st As Worksheet, ppt As PowerPoint.Application, sl As PowerPoint.slide) ClipboardClear 'copy table Dim copyRange As Range Set copyRange = st.Range(XLS_COPY_RG) copyRange.Copy WaitCopyInterval 'paste table Dim pasteTableShape As PowerPoint.Shape Dim pasteTable As PowerPoint.Table Dim pasteCell As PowerPoint.Cell Set pasteTableShape = sl.Shapes(PPT_TABLE_NAME) pasteTableShape.Select Set pasteTable = pasteTableShape.Table Set pasteCell = pasteTable.Cell(PPT_TABLE_ROW_IDX, PPT_TABLE_COL_IDX) pasteCell.Select 'PowerPoint2013用の貼り付け '(画面上の貼り付けボタンを操作) 'ppt.CommandBars.ExecuteMso "PasteExcelTableDestinationTableStyle" 'PowerPoint2010用の貼り付け '(PowerPoint2010では"ExecuteMso"の遅延が大きくエラーになりやすいため。) ppt.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault '(参考)確実に処理したい場合、次のようにセル個別に値を代入する方法もある 'pasteCell.Shape.TextFrame.TextRange.Text = 100 WaitOpeInterval End Sub 'グラフをコピーする。 Sub CopyGraph(st As Worksheet, sl As PowerPoint.slide) ClipboardClear 'Excel上のグラフをコピー Dim copyChart As ChartObject Set copyChart = st.ChartObjects(XLS_GRAPH_NAME) copyChart.Select copyChart.Copy WaitCopyInterval 'PowerPointにグラフを貼り付け '(PowerPoint2010環境では、PasteSpecialエラー時にクリップボードの 'データが不正となりリトライできない。) Dim pasteFigure As PowerPoint.ShapeRange Dim i As Integer On Error Resume Next For i = 1 To RETRY_COUNT Err.Clear Set pasteFigure = sl.Shapes.PasteSpecial(ppPastePNG) If Err.Number = 0 Then Exit For End If Debug.Print "PasteSpecial(" & i & "): " & Hex(Err.Number) & ": " & Err.Description Set pasteFigure = Nothing If i < RETRY_COUNT Then WaitCopyInterval End If Next On Error GoTo 0 If pasteFigure Is Nothing Then Err.Raise Number:=513, Description:="図の貼り付けリトライで失敗しました。" End If pasteFigure.Name = PPT_GRAPH_NAME pasteFigure.Top = Application.CentimetersToPoints(PPT_GRAPH_TOP) pasteFigure.Left = Application.CentimetersToPoints(PPT_GRAPH_LEFT) WaitOpeInterval End Sub '初期化インターバル '(起動／終了時の比較的長い待機時間用) Sub WaitPhaseInterval() DoEvents Sleep PHASE_INTERVAL DoEvents End Sub '操作インターバル '(各処理間の待機時間用) Sub WaitOpeInterval() DoEvents Sleep OPE_INTERVAL DoEvents End Sub 'コピーインターバル '(コピー直後用の待機時間用) Sub WaitCopyInterval() DoEvents Sleep COPY_INTERVAL DoEvents End Sub 'クリップボードの内容をクリア Sub ClipboardClear() DoEvents Dim cb As New DataObject cb.SetText Empty cb.PutInClipboard DoEvents End Sub |