snack.elve.club
パワポ編
これの該当部を置換して指定枚数印刷。(面倒になったので保存すらしないw)
- テンプレファイルを開く
- スライド内のシェイプの文字列置換
- 印刷
- テンプレを保存しないで閉じる
を繰り返すことにします。(担当者30名ほどなのでこれで行けましたがもっと多いなら、ファイル操作は少なくしたほうが良いような気がします。なんとなく)
ファイルは
- 差込用リスト.xlsm
- 挨拶文差込.pptx
エクセルはこんな感じでここから実行
スライド1枚、テキストボックス2個のシンプルなパワポなんで力技で・・・
なーんかもっといい方法あるとおもうんだけどなぁ・・・(プレゼンテーションの一括置換あるし)
マクロの記録させてくれよ、パワポ!!
Sub パワポ処理() 'パワポの準備 Dim app As PowerPoint.Application: Set app = CreateObject("PowerPoint.Application") app.Visible = True '担当者情報 Dim i As Integer Dim 担当者数 As Integer: 担当者数 = Worksheets("担当者").Range("A1").End(xlDown).Row Dim 担当者: 担当者 = Worksheets("担当者").Range("A1").CurrentRegion For i = 2 To 担当者数 'テンプレート読み取り専用で開く Dim pre As PowerPoint.Presentation: Set pre = app.Presentations.Open("F:\20210606_差込\挨拶文差込.pptx", msoTrue) 'スライド1固定 Dim sld As PowerPoint.Slide: Set sld = pre.Slides(1) Dim shp As PowerPoint.Shape 'テキストボックスしかないから判定しない For Each shp In sld.Shapes With shp.TextFrame.TextRange 'TextRangeでReplaceするとフォント変わっちゃうので・・・ Dim t As String t = .Text t = Replace(t, "<担当(フルネーム)>", 担当者(i, 1)) t = Replace(t, "<担当者(名字)>", Left(担当者(i, 1), InStr(担当者(i, 1), " ") - 1)) .Text = t End With Next '印刷 pre.PrintOut copies:=担当者(i, 2) Set sld = Nothing pre.Saved = True pre.Close Set pre = Nothing Next app.Quit Set app = Nothing End Sub
参考サイト