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