Excelからテンプレ・ひな型のPowerPointを開き B列のデータセット後 A列の名前を付けて保存するそんなテスト

B2のパワポファイル、フルパスを開き、B3で指定したスライドページの
B4名前のテキストボックスにB10列～データセット後、A10列の名前で上書き保存する

まぁ、↑シートイメージを見た方が早いですね。

テスト動画
youtu.be
https://youtu.be/mof40MhZrYw
目次
00:00 やりたいこと
01:30 2.テンプレを変更して　テスト実演
03:19 2.3 マクロを実行する
04:51 2.4 余談図形のテキストにもセットできたりします
08:45 2.5 テンプレを変えて、再テスト
10:46 3.簡単なコード説明
15:02 4.おっと、次回の課題は

0.キッカケは、
下記知恵袋の質問にチャレンジしてみた

detail.chiebukuro.yahoo.co.jp

パワーポイントのファイル名をエクセルのセル値で大量に保存するマクロを作りたいです。
加えてパワーポイントのテキストボックスにエクセルのセル値を反映させたいです。
エクセルはA列とB列を使います。
B1セルの文字列をパワーポイントのテキストボックスに貼り付け、
名前を付けて保存でA1セルの文字列で保存する。
B2セル値を貼り付け、A2セル値で名前を付けて保存。
B3セル値を貼り付け、A3セル値で名前を付けて保存。
これを入力されている行数分繰り返したいです。
例えば100行あれば100個分のパワーポイントができあがるイメージです。
マクロに詳しい方お助けください。

1.勝手に仕様変更ぉぃぉぃ ....

基準(ひな型テンプレ)パワポのファイル
と
セットするテキストボックスを指定したかったので、

2.テンプレを変更して　テスト実演

2.1 データを流し込む先、テンプレートファイルを用意します
ポイントは特になく、
ホーム配置オブジェクトの選択と表示
で、右側にオブジェクト名を表示させます

↑ここで、ターゲット(流し込む先)のテキストボックス名がわかります。
※ダブりクリック後、わかりやすい名前に変えることもできます

2.2 ページ数と名前をセットする

2.3 マクロを実行する
マクロを実行して結果を確認します

2.4 余談図形のテキストにもセットできたりします
蛇足ですが、図形のテキストもセットできます

2.5 テンプレを変えて、再テスト

3.簡単なコード説明

Option Explicit

'B2のパワポファイル、フルパスを開き、B3で指定したスライドページの
'B4名前のテキストボックスにB10列～データセット後、A10列の名前で上書き保存する
Sub test_ExcelからPowerPointひな型にデータセット後別名保存()

    '入力テンプレ:パワポのファイルを開く
    Dim ppApp As PowerPoint.Application 'ツール・参照設定してください

    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True '可視にする

    'いつもActivePresentationでやってるけど、たまには変数を使用
    Dim ppプレゼン As PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppプレゼン = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set ppプレゼン = ppApp.Presentations.Open(Range("B2")) 'B2のファイル名を開く
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If ppプレゼン Is Nothing Then
        MsgBox "B2パワポのファイル名、パスを確認してください", vbExclamation
        Exit Sub
    End If

    Dim ppPAGE As Integer   'セットする pp:スライドページ数
    ppPAGE = Range("B3")    'B3の値を使用
    
    Dim ppTEXTNAME As String   'セットする pp:テキストボックス名
    ppTEXTNAME = Range("B4")   'B4の値を使用
    
    'ループ処理でパワポファイルを作成する
    Dim nROW  As Integer    'Excle:指示パラメーターの行
    Dim ppShape As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    Dim strWORK As String
    Dim strFILENAME As String  '保存ファイル名をPath付きで作成する
    
    'ExcelのA10～にある指示データがなくなるまでループしたいので
    For nROW = 10 To 999  'また、固定のループで↓の空白で抜けるループかよ
        If Len(Trim(Cells(nROW, "A"))) = 0 Then Exit For 'A列の保存名が空白の時ループを

抜ける

        Set ppShape = Nothing  'エラーチェックも兼ねて、初期化
        On Error Resume Next   '↓でSet 取得エラー時に次へ ページかテキストボックス名が

間違えている時
        Set ppShape = ppプレゼン.Slides(ppPAGE).Shapes(ppTEXTNAME)
        '↑のB3:PageとB4:テキストボックス名でセット位置を決める
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

        If ppShape Is Nothing Then  'ページかテキスト名がミスっていたら
            strWORK = "エラー パワポのpageかテキスト名が見つかりません、確認してください

"
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If

        'ppテキストにExcel側のB列のデータをセットする
        ppShape.TextFrame.TextRange.Text = Cells(nROW, "B").Text

        'A列の名前で上書き保存する、ここでは、エクセルと同じPathに保存
        strFILENAME = ActiveWorkbook.Path & "\" & Cells(nROW, "A").Text & ".pptx"
        ppプレゼン.SaveAs strFILENAME
        DoEvents

    Next nROW
    
    'pp側の後始末、パワポを閉じる
    DoEvents
    ppApp.Quit    'パワポアプリを閉じる
    DoEvents
    Set ppプレゼン = Nothing
    Set ppApp = Nothing
    
    MsgBox "処理終了、確認してね"

End Sub

3.1 テンプレファイルを開いて

Presentations.Open ファイル名
で開く、
Set ppプレゼン = ppApp.Presentations.Open(Range("B2"))
で結果がppプレゼンに返るので、
If ppプレゼン Is Nothing Then
でチェックしただけ

    Dim ppプレゼン As PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppプレゼン = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set ppプレゼン = ppApp.Presentations.Open(Range("B2")) 'B2のファイル名を開く
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If ppプレゼン Is Nothing Then
        MsgBox "B2パワポのファイル名、パスを確認してください", vbExclamation
        Exit Sub
    End If

3.2 Excel側のセットデータがなくなるまでループ

いつもの手抜き、悪いコードの見本ですが
For nROW = 10 To 999
で、For nROWでカウントアップ、
If Len(Trim(Cells(nROW, "A"))) = 0 Then Exit For
で抜けてます※A列が空白になるまでのループ
最近のトレンドは、
For i = 10 To Cells(Rows.Count, 1).End(xlUp).row
みたいなかき方なので、↑こちらをぐぐってみてね。(悪い癖を直さないとなぁ・・・)

    'ExcelのA10～にある指示データがなくなるまでループしたいので
    For nROW = 10 To 999  'また、固定のループで↓の空白で抜けるループかよ
        If Len(Trim(Cells(nROW, "A"))) = 0 Then Exit For 'A列の保存名が空白の時ループを

抜ける

3.3 セット先の確認を兼ねてオブジェクトの代入

        Set ppShape = Nothing  'エラーチェックも兼ねて、初期化
        On Error Resume Next   '↓でSet 取得エラー時に次へ ページかテキストボックス名が

間違えている時
        Set ppShape = ppプレゼン.Slides(ppPAGE).Shapes(ppTEXTNAME)
        '↑のB3:PageとB4:テキストボックス名でセット位置を決める
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意

        If ppShape Is Nothing Then  'ページかテキスト名がミスっていたら
            strWORK = "エラー パワポのpageかテキスト名が見つかりません、確認してください

"
            MsgBox strWORK, vbExclamation
            Exit Sub
        End If

↑スライドのページ位置と名前で目的のオブジェクト

が指定できます
Set ppShape = ppプレゼン.Slides(ppPAGE).Shapes(ppTEXTNAME)
これを利用して、セットできなかったら(見つからなかったら)
If ppShape Is Nothing Then でテストしました。

3.4 あとは単純に

        'ppテキストにExcel側のB列のデータをセットする
        ppShape.TextFrame.TextRange.Text = Cells(nROW, "B").Text

と、TextFrame.TextRange.Textにセットしただけです

3.5 名前を付けて保存する SaveAs

        'A列の名前で上書き保存する、ここでは、エクセルと同じPathに保存
        strFILENAME = ActiveWorkbook.Path & "\" & Cells(nROW, "A").Text & ".pptx"
        ppプレゼン.SaveAs strFILENAME
        DoEvents