ExcelからPowerPointへ A列のデータを2件単位 3件単位でPowerPointへ流し込む 差し込み印刷みたいな処理

コメント欄の質問:A列のデータ2件,3件をパワポの1スライドへセット、チャレンジしてみました。洋服屋の店員なら怒られているようなサイズ調整(コード修正)ですが、イメージと合っていて、アレンジして着こなしてらえるとうれしいです・・・
解説開始・テスト開始
https://www.youtube.com/watch?v=bGWBies-80U&list=PL8vZhsyiiFhtDYDOdz94s6bQ54vwPRN-3&t=230s&pp=gAQBiAQB

セット項目名をアレンジする方法　自分の環境・体型に型を合わせる
https://www.youtube.com/watch?v=bGWBies-80U&list=PL8vZhsyiiFhtDYDOdz94s6bQ54vwPRN-3&t=1504s&pp=gAQBiAQB

3.左右の列に真ん中を入れて三列にしてみる 三列にアレンジしてみる
https://www.youtube.com/watch?v=bGWBies-80U&list=PL8vZhsyiiFhtDYDOdz94s6bQ54vwPRN-3&t=1899s&pp=gAQBiAQB

上記、URL同じ動画で、飛ぶ先が違うだけです、お時間のある時に見て、笑ってください。
何かあれば、コメント欄に気軽に書いてください。

作成した動画:
www.youtube.com
https://www.youtube.com/watch?v=bGWBies-80U
目次
00:00 1.やりたいこと。
02:15 サンプルでピッタリが無い 合うコードが無い
03:50 2.カスタム　オーダーメードで2件セットを作ってみた
04:30 2.2 実行する
05:57 2.3 テンプレを修正、データを追加して再テスト
08:00 再度、テンプレート・ひな形を修正してテストする
11:02 2.4 コードの簡単な説明
17:00 セットするパワポの項目名をアレンジする方法 右側見えなくてスミマセン
23:02 次の行にyカウンタが進み、コピーの判断を行う
25:04 オーダーメードの調整方法を説明
28:01 セット位置のオブジェクト・シェイプ名を変更して、わかりやすくする

31:39 3.左右の列に真ん中を入れて三列にしてみる 三列にアレンジしてみる
32:54 話を脱線する イメージ作成のプロンプトでエラーが発生した話

34:00 三列用のテンプレートを作成する
36:04 セットするシェイプ名をひな形で変更する
38:13 コードを3列対応に修正する
40:46 3列対応 改ページのタイミングを説明する
42:20 データセットを偶数奇数からSelect Caseで3パターンに変更する
45:54 テスト開始 一回目 ファイル名でエラーが出る
47:32 再テスト 変数名の違いに気が付くのが遅すぎです・・・笑ってください
49:42 コピペのミス？とても恥ずかしいミスを発見・・・

1.やりたいこと。

動画のコメント欄に質問をいただきました。

>例えば、１スライドに並列で２店舗や３店舗などの流し込みもできるのでしょうか？
>A列に店舗名があって、
>1スライドには最初の２店舗分の情報で次のスライドも同じように２店舗などを繰り返すとか…

Excel
A列
麺屋一番
カレーの王様
ピザハウス
お好み焼き太郎
寿司の美味しい店

を

PowerPoint 2列1スライド

スライド1 麺屋一番 | カレーの王様
スライド2 ピザハウス | お好み焼き太郎
スライド3 寿司の美味しい店 | (空白)

や
PowerPoint 3列1スライド

スライド1 麺屋一番 | カレーの王様 | ピザハウス
スライド2 お好み焼き太郎 | 寿司の美味しい店 | (空白)

を作りたいって事ですよね・・

ズバリのコードは私の動画やサンプルには残念ながら無いので、
似ているのは、
https://www.youtube.com/live/VUw8a-xW55w?si=-ndVWSm0N2ylavSr&t=194
だけど、
A列,B列,C列
page,オブジェクト名,値
をセットするので、
Excelを隣のシートでpageは2個単位,オブジェクト名を交互に追加して
A列,B列,C列
page,オブジェクト名,値
1,テキスト店名左,麺屋一番
1,テキスト店名右,カレーの王様
2,テキスト店名左,ピザハウス
2,テキスト店名右,お好み焼き太郎
3,テキスト店名左,寿司の美味しい店
3,テキスト店名右,(空白)

と、思ったけど、
A列の数が不定だから、
先にパワポでスライドの枚数合わせが必要なので、
実用的では無かったり。

簡単に、2列,3列対応できないか？
少し、考えてみますね。

2.カスタム　オーダーメードで2件セットを作ってみた

少し、考えてみた。おいおい。
過去に作った、テンプレートにセットするコード
https://www.youtube.com/watch?v=-GVsj_kYbMI
を修正してみた。

2.1 テンプレートをまず見せる 03:50
https://www.youtube.com/live/bGWBies-80U?si=4EPUy6vuAEfs8_gv&t=230

2.2 実行する 04:30
https://www.youtube.com/live/bGWBies-80U?si=fm7qiPLA8Py2BNPO&t=270

2.3 テンプレを修正、データを追加して再テスト 05:57
https://www.youtube.com/live/bGWBies-80U?si=lNF60SEjxVVhznXW&t=357

08:00 再度、テンプレート・ひな形を修正してテストする

2.4 コードの簡単な説明
https://www.youtube.com/live/bGWBies-80U?si=W7KKhTy9ciD6VZim&t=662

セット項目名をアレンジする方法　自分の環境・体型に型を合わせる 25:04 ～
https://www.youtube.com/live/bGWBies-80U?si=1O3ShWyQ8C-rRKaH&t=1504

'パワポのテンプレートを開き
'A列を2件単位で　左右にセットする
Sub test231212_A列を2件単位でパワポへ()

    'PowerPointアプリの起動
    Dim ppApp As Object   'PowerPoint.Application
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True '可視にする
    DoEvents

    'ひな型 テンプレ ファイルを開く
    Dim strPPFName As String
    strPPFName = ActiveWorkbook.Path & "\ひな型231212左右.pptx"  '※Excelと同じ場所を開く

    '↑上のテンプレ内のセット名をここで代入する
    Const str左セット名 = "四角形: 角を丸くする 7"
    Const str右セット名 = "四角形: 角を丸くする 9"

    '開く、コピー元を変数に入れる
    Dim ppひな型 As Object  'PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppひな型 = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set ppひな型 = ppApp.Presentations.Open(strPPFName, msoTrue) 'リードオンリーで開く
    DoEvents
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If ppひな型 Is Nothing Then '↑上で開けたか？
        'openエラーの時、開けなかったことを知らせる
        MsgBox strPPFName & "が開けません確認してください", vbExclamation
        Exit Sub  'んっ？空のppAppが残るか、これだと・・・
    End If
    
    '新規の枠、新規プレゼンの作成
    Dim pp新規 As Object  'As PowerPoint.Presentation
    Set pp新規 = ppApp.Presentations.Add(WithWindow:=msoTrue) '新規追加
    
    '2023/06/25 追加 スライドの方向をそろえる PageSetup.SlideOrientation
    pp新規.PageSetup.SlideOrientation = ppひな型.PageSetup.SlideOrientation
    '↑新規とひな型のページ方向をそろえる。※A4とA3とかサイズ違いは未対応

    Dim ppSlide As Object  'As PowerPoint.Slide に入れてコピペ後のスライドを操作
    Dim y As Long  '行カウンタ
    Dim ppShape     As Object 'As PowerPoint.Shape シェイプを代入

    'A列が存在する間ループする
    y = 1    'A1から始めたいので 1
    While Len(Trim(Cells(y, "A"))) > 0  'A列のデータが存在する間、ループする
        '改ページチェック 1,3,5,7,,,奇数の件数で改ページ処理する
        If (y Mod 2) = 1 Then '2で割った余りが1なら奇数です
            '新規パワポへひな型テンプレをコピーする
            ppひな型.Slides.Range(1).Copy  '単純に1ページ目をコピー
            DoEvents
            '新規に貼り付ける。新スライドページの作成
            Set ppSlide = pp新規.Slides.Paste   'ひな型を新プレゼンの最後に追加貼り付け
            '↑ペーストついでに、変数にセットしておくと、便利ですよ
            DoEvents
            '左右のセット先データを先にクリアする
            ppSlide.Shapes(str左セット名).TextFrame.TextRange.Text = ""
            ppSlide.Shapes(str右セット名).TextFrame.TextRange.Text = ""
            'セット先が無い時のエラーは？手抜きかよ・・・運用でカバー？
            DoEvents
        End If
        
        'データのセット 左右を偶数奇数で判断してセットする
        If (y Mod 2) = 1 Then '2で割った余りが1なら奇数です
            '奇数は左
            ppSlide.Shapes(str左セット名).TextFrame.TextRange.Text = Cells(y, "A")
        Else
            '偶数は右
            ppSlide.Shapes(str右セット名).TextFrame.TextRange.Text = Cells(y, "A")
        End If
        
        y = y + 1  '次の行へ※忘れて無限ループはシャレにならないよ・・・
        
    Wend
    
    'ひな型は閉じる
    ppひな型.Close
    DoEvents
    Set ppひな型 = Nothing
 
    MsgBox "処理終了、結果を確認してね"

End Sub

3.左右の列に真ん中を入れて三列にしてみる 31:39～
https://www.youtube.com/live/bGWBies-80U?si=BqFKa1DrYis8EvIT&t=1899

三列対応、応用してみる。

自分でサイズを調整するには・・

試しに三列を作成してみる。
34:00 三列用のテンプレートを作成する

Option Explicit

'パワポのテンプレートを開き
'A列を3件単位で　左,中,右にセットする
Sub test231212_A列を3件単位でパワポへ()

    'PowerPointアプリの起動
    Dim ppApp As Object   'PowerPoint.Application
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True '可視にする
    DoEvents

    'ひな型 テンプレ ファイルを開く
    Dim strPPFName As String
    'strPPFName = ActiveWorkbook.Path & "\ひな型231212左右.pptx"  '※Excelと同じ場所を開く
    strPPFName = ActiveWorkbook.Path & "\ひな型231212左中右.pptx"  '※Excelと同じ場所を開く

    '↑上のテンプレ内のセット名をここで代入する
    Const str左セット名 = "店舗左"
    Const str中セット名 = "店舗中"
    Const str右セット名 = "店舗右"

    '開く、コピー元を変数に入れる
    Dim ppひな型 As Object  'PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppひな型 = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set ppひな型 = ppApp.Presentations.Open(strPPFName, msoTrue) 'リードオンリーで開く
    DoEvents
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If ppひな型 Is Nothing Then '↑上で開けたか？
        'openエラーの時、開けなかったことを知らせる
        MsgBox strPPFName & "が開けません確認してください", vbExclamation
        Exit Sub  'んっ？空のppAppが残るか、これだと・・・
    End If
    
    '新規の枠、新規プレゼンの作成
    Dim pp新規 As Object  'As PowerPoint.Presentation
    Set pp新規 = ppApp.Presentations.Add(WithWindow:=msoTrue) '新規追加
    
    '2023/06/25 追加 スライドの方向をそろえる PageSetup.SlideOrientation
    pp新規.PageSetup.SlideOrientation = ppひな型.PageSetup.SlideOrientation
    '↑新規とひな型のページ方向をそろえる。※A4とA3とかサイズ違いは未対応

    Dim ppSlide As Object  'As PowerPoint.Slide に入れてコピペ後のスライドを操作
    Dim y As Long  '行カウンタ
    Dim ppShape     As Object 'As PowerPoint.Shape シェイプを代入

    'A列が存在する間ループする
    y = 1    'A1から始めたいので 1
    While Len(Trim(Cells(y, "A"))) > 0  'A列のデータが存在する間、ループする
        '改ページチェック 1,4,7,10,,,3の件数で改ページ処理する
        If (y Mod 3) = 1 Then '3で割った余りが1なら奇数です
            '新規パワポへひな型テンプレをコピーする
            ppひな型.Slides.Range(1).Copy  '単純に1ページ目をコピー
            DoEvents
            '新規に貼り付ける。新スライドページの作成
            Set ppSlide = pp新規.Slides.Paste   'ひな型を新プレゼンの最後に追加貼り付け
            '↑ペーストついでに、変数にセットしておくと、便利ですよ
            DoEvents
            '3件のセット先データを先にクリアする
            ppSlide.Shapes(str左セット名).TextFrame.TextRange.Text = ""
            ppSlide.Shapes(str中セット名).TextFrame.TextRange.Text = ""
            ppSlide.Shapes(str右セット名).TextFrame.TextRange.Text = ""
            'セット先が無い時のエラーは？手抜きかよ・・・運用でカバー？
            DoEvents
        End If
        
        'データのセット 左右を偶数奇数で判断してセットする
        Select Case (y Mod 3)
            Case 1:
                '左
                ppSlide.Shapes(str左セット名).TextFrame.TextRange.Text = Cells(y, "A")
            Case 2:
                '中
                ppSlide.Shapes(str中セット名).TextFrame.TextRange.Text = Cells(y, "A")
            Case 0:   'ここ注意
                '右
                ppSlide.Shapes(str右セット名).TextFrame.TextRange.Text = Cells(y, "A")
        End Select
        
        y = y + 1  '次の行へ※忘れて無限ループはシャレにならないよ・・・
        
    Wend
    
    'ひな型は閉じる
    ppひな型.Close
    DoEvents
    Set ppひな型 = Nothing
 
    MsgBox "処理終了、結果を確認してね"

End Sub

4.
配列は、次回で

質問あったら、コメントに書いてください。

解決のヒントとなれば、幸いです。

---

おまけイメージ作成プロンプトで失敗・・・