趣味プログラミングblog

---

参考になったのがこのページ。

https://powervbadesktop.com/powerpoint1/

エクセルとパワポの対応関係が図解してあって、すぐに理解できた。


次にソースを調べてみる。

エクセルからパワポに転記するにはいくつかヒットするけど、
どのサイトもエクセル側のVBAを使ってる。

パワポ側は貼り付けるだけで、複雑なことはしないから
エクセルVBAのライブラリを活用した方が得と判断したのかな。


参考になったページ
https://excel-ubara.com/excelvba5/EXCELVBA280.html

参照設定なしで、エクセルVBAからパワポを操作する方法が書いてある。

---

エクセルVBAでパワポ操作をできるようになったところで、仕様検討。

やりたいことは、前月のレポートから図と表の差し替え。
悩ましいのが、パワポ上の図や表からどうやって差し替え対象のものを見つけるか。

これがわからずペンディング。


全然閃かないので、手作業でやることにした。
やっていて気付く。手作業の一部だけでもマクロ使って楽すればいいじゃん。

そんなマクロを作っているうちに閃いた。
更新対象の図や表の名前をこちら側で指定して、テンプレファイルにすれば良いじゃん。

---

Alt+F10で、オブジェクトの一覧を表示できるので、
更新対象の名前を定数として定義して、パワポ側の名称を修正した。
Const tblName = "targetTable" '更新対象のPPTの表の名前
Const ttlName = "targetTitle" '更新対象のタイトルの名前
（同じスライドに同じ名前があるとうまくいかないので注意）

図については、前月分を全消しして、指定の位置に貼り付ければいいことに気付いた。

エクセル側の図は、毎回「図 1」という名前になるようなので、これを指定。

表については、PPT側の表の文字列をエクセルの文字列をセットすることにした。
テキストを指定するのにめっちゃ長い。。。

tarPP.slides(tarSld).Shapes(tblName).Table.cell(Gyo, Retsu).Shape.TextFrame.TextRange.text

---

そんな感じで以下ソース。
ソースコードファイルは こちら。

Option Explicit

Sub copyContents()
Const figName = "図 1" 'エクセルからコピペする図の名前
Const tblName = "targetTable" '更新対象のPPTの表の名前
Const ttlName = "targetTitle" '更新対象のタイトルの名前

Const xPos = 0 'ｐｐｔに図を貼り付ける水平位置（ｃｍ）
Const yPos = 3.15 'ｐｐｔに図を貼り付ける垂直位置（ｃｍ）

'前月の図を削除する
Dim ppApp As Object: Set ppApp = CreateObject("PowerPoint.Application")
If ppApp.Visible = 0 Then errorEnd ("貼り付け先のPPTを開いてから実行してください。")

Dim tarPP As Object: Set tarPP = ppApp.ActivePresentation
Call PowerPointの図を全消しする2(tarPP)

'サブルーチン用変数を用意　スライド番号、横位置、縦位置
Dim tarSld As Long

Const strTLcol = "B"
Const titleTblRow = 3
Const reportTblRow = 22

Dim strLastMonth As String
strLastMonth = (12 + Month(Now) - 2) Mod 12 + 1 '前月を

Dim sh As Long, mRange As range 'pptへ転記するテーブル

'Title
sh = 1: tarSld = 2
Set mRange = Worksheets(sh).Cells(titleTblRow, strTLcol).CurrentRegion 'Worksheets(1).Cells(3, "B").CurrentRegion.Copyはやめた
Call PowerPointの表を更新(tarPP, mRange, tarSld, tblName)

Dim rpNum As Long
For rpNum = 1 To 3 'Report1 CPU使用率 'Report2 空きメモリ容量 'Report3 ディスク使用率
'図の更新 '
sh = sh + rpNum: tarSld = tarSld + rpNum '対象シート、対象スライドを変更
Worksheets(sh).Shapes(figName).Copy
Call PowerPointの図を貼り付ける(tarPP, tarSld, xPos, yPos)

'表の更新
Set mRange = Worksheets(sh).Cells(reportTblRow, strTLcol).CurrentRegion
Call PowerPointの表を更新(tarPP, mRange, tarSld, tblName)

'タイトルの更新【●月レポート】
Call PowerPointのタイトルを更新(tarPP, tarSld, ttlName, strLastMonth)
Next rpNum
End Sub

Sub PowerPointの表を更新(tarPP, mRange As range, tarSld As Long, tblName As String)
Dim rCnt As Long: rCnt = mRange.Rows.Count
Dim cCnt As Long: cCnt = mRange.Columns.Count
Dim Gyo As Long, Retsu As Long
For Gyo = 1 To rCnt
For Retsu = 1 To cCnt
tarPP.slides(tarSld).Shapes(tblName).Table.cell(Gyo, Retsu).Shape.TextFrame.TextRange.text = mRange(Gyo, Retsu).text
Next Retsu
Next Gyo
End Sub




Sub PowerPointのタイトルを更新(tarPP, tarSld As Long, ttlName As String, strLastMonth As String)
With tarPP.slides(tarSld).Shapes(ttlName)
tarPP.slides(tarSld).Select
.TextFrame.TextRange.text = "【" & strLastMonth & "月レポート】"
End With
End Sub



Sub PowerPointの図を貼り付ける(tarPP, tarSld As Long, xPos As Double, yPos As Double)
With tarPP.slides(tarSld).Shapes.Paste
'コピー元の位置に移動
.Left = xPos * 72 / 2.54
.Top = yPos * 72 / 2.54
.ZOrder msoSendToBack
End With
End Sub



Sub PowerPointの図を全消しする2(tarPP)
Const debugFlag = 0
Dim figType As Long '.ActivePresentation.Slides(sld).Shapes(shp).Type
Dim sld As Long, eSld As Long
Dim shp As Long, eShp As Long
eSld = tarPP.slides.Count
For sld = 1 To eSld
eShp = tarPP.slides(sld).Shapes.Count
For shp = eShp To 1 Step -1
If debugFlag > 0 Then Debug.Print "sld=" & sld & " shp=" & shp & " |" & tarPP.slides(sld).Shapes(shp).Type
figType = tarPP.slides(sld).Shapes(shp).Type
If figType = 13 Or figType = 1 Then '13:グラフ、1:シェイプ
tarPP.slides(sld).Shapes(shp).Delete
End If
Next shp
Next sld
End Sub



Private Sub errorEnd(msg)
MsgBox msg
End
End Sub