エクセルデータからパワポスライドを自動作成 テンプレート修正 差し込みテンプレートの修正手順を説明

パワポのマクロを使ってエクセルのデータからスライドを自動作成する方法について、
テンプレートの修正方法やコードの説明などを丁寧に説明してみる
#PowerPointVBA #テンプレート #自動作成

キーワード:
パワポ,マクロ,エクセル,スライド,自動作成,テンプレート,修正,コード

タイトル案:

• パワポマクロでエクセルデータからスライドを自動作成！テンプレート修正方法も解説
• エクセルデータからパワポスライドを自動作成する方法とテンプレート修正のコツ
• パワポマクロでエクセルデータからスライドを自動作成する裏技！テンプレート修正方法も紹介

www.youtube.com
https://www.youtube.com/watch?v=p-zOgNiErF8
目次:
00:00 あいさつ、不具合内容と修正依頼
01:23 1.タイトル 1 とか紛らわしい名前にしていたのが間違いの元・・・
02:30 1.1 素直に日付1を右上に移動すればいいのかな？
06:12 1.2 グループ化と名前を付ける
09:03 .Value と .Text の違いをテスト
12:52 2.なんでタイトルを使ったの？説明してよ
13:13 3.終わりのあいさつ 追伸: ファイル名には/が 使えない

前回の処理:差し込み印刷っぽい処理 エクセルのデータからパワポのスライドを自動作成する Excel To PowerPoint
https://www.youtube.com/watch?v=tprejIA-Q-M&list=PL8vZhsyiiFhtDYDOdz94s6bQ54vwPRN-3&index=1&t=1299s
上記処理について下記の質問をいただく
バグ、不具合の連絡をいただく。

＞②元のテンプレートで、
＞テキストボックスの配置や文字の大きさで展開されるとはおもいます。
＞PowerPointの貼付け配置レイアウトは
＞Excel上日付はページ分けする意味で必要なのですが、
＞ページの右上にA列の月日（曜日）を一つのみ転記。
＞レコードの貼付けは
＞会場名、時間（開始・終了時刻）、催事名、主催者名
＞縦シートに転記したいです。
＞タイトルは不要でレコードのみ貼付けになります。

1.タイトル 1 とか紛らわしい名前にしていたのが間違いの元・・・

テンプレートの修正方法を実演する。

'ページが変わったので、タイトルをセット
ppSlide.Shapes("タイトル 1").TextFrame.TextRange.Text = PageCODE 'キーをタイトルにセット
DoEvents

これが、誤解を招いた・・・
Shapes("タイトル 1")
を必ず使うのかと・・・思わせてしまった。

まず、このコードをコメントにします。

やりたいこと

＞ページの右上にA列の月日（曜日）を一つのみ転記。

1.1 素直に日付1を右上に移動すればいいのかな？

日付は１～５でタテに連続セットはしない

ので、

テンプレートの
タイトルを削除する。
※日付1 を 右上に移動。

日付2～5 を 削除する。
※セット先の項目名が無くても、

            'Excelから単純にItem(項目名)でデータセット、エラーを無視して項目名無しを回避
            On Error Resume Next  'エラーが発生しても強引に次の命令に行け
            Set ppShape = Nothing  'これが無いと、前回オブジェクトが残る
            Set ppShape = ppSlide.Shapes(str転記列名) 'セットするオブジェクト
            ppShape.TextFrame.TextRange.Text = Cells(y, x).Text 'Excelから文字列を代入
            On Error GoTo 0  '忘れないで戻すぞ

で、無視するだけなので。

そんな方針でいってもいいのかなぁ。

1.2 グループ化と名前を付ける

グループ化と名前を付けたテキストボックスを 右上に用意する

'ページが変わったので、グループ化をセット
ppSlide.Shapes("グループ化").TextFrame.TextRange.Text = PageCODE 'キーをグループ化にセット
DoEvents

日付はセットしないので、日付1～5を削除する。
※セット先の項目名が無くても、

            'Excelから単純にItem(項目名)でデータセット、エラーを無視して項目名無しを回避
            On Error Resume Next  'エラーが発生しても強引に次の命令に行け
            Set ppShape = Nothing  'これが無いと、前回オブジェクトが残る
            Set ppShape = ppSlide.Shapes(str転記列名) 'セットするオブジェクト
            ppShape.TextFrame.TextRange.Text = Cells(y, x).Text 'Excelから文字列を代入
            On Error GoTo 0  '忘れないで戻すぞ

で、無視するだけなので。

Shapes("グループ化")んっ？ネーミングセンスないな・・・
なんだろう？
キーじゃないし、次のバグ・修正、不具合・要望追加で、jpgに保存するから、
JPGFileNameとかでもいいんだけど。※これは、未来の話だからまだ、いっか。

あっ、違う、違う。
ppSlide.Shapes("グループ化").TextFrame.TextRange.Text = PageCODE
だと、
PageCODEをセットしている。

これって、
PageCODE = Cells(y, "A") '値を保存する※このキー値の間処理をするため保存
で、保存しているので、
Cells(y, "A")のデフォルト、
Cells(y, "A").Value
って感じで、
日付型なら、6/1なら、2023/06/01 とかなるから、
Cells(y, "A").Text 指定したほうがいいね・・・
※しないと、

＞ページの右上にA列の月日（曜日）を一つのみ転記。
曜日、表示できないじゃん。

A列の表示形式で、
mmdd(aaa)にしないとね。

んっ？もう汎用性なんて考えないで、
ppSlide.Shapes("グループ化").TextFrame.TextRange.Text = Format(PageCODE,"mm/dd aaa")
とかで、いいのかな？

少し脱線。

2.なんでタイトルを使ったの？説明してよ

なんとなく、タイトルにセットした方がいいかなぁ・・・って思って。
分類とかグループとか、初めに違う名前でテキストボックス作ればよかったかな。

3.終わりのあいさつ

以上、
まだまだ、
不親切なテンプレファイルの仕組みだけど、
アレンジして使ってみてください。

追伸: ファイル名には / が 使えないので、 06/25.jpg は無理なので、少し工夫が必要かなぁ。
って、次の要望を小出しにしてしまった・・・

'タイトル 1を改め、.Shapes("グループ化")にセットしてみた
' 
' ↑の開設動画をみてください。
Sub デバッグ20230625_02Aタイトルのセット中止()

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

    'ひな型ファイルを開く
    Dim strPPFName As String
    strPPFName = "D:\テンプレート\テンプレ0625縦.pptx"  '※固定でフルパス
    
    'strPPFName = "D:\テンプレート\テンプレ0620.pptx"  '※固定でフルパス
    '↑デバッグで用意した縦スライドをテンプレ元にする

    '開く、コピー元を変数に入れる
    Dim ppひな型 As Object  'PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppひな型 = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set ppひな型 = ppApp.Presentations.Open(strPPFName) 'ファイル名を指定して開く
    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 PageCODE  As Variant  'この値がキーが変更されたら改ページする
    
    Dim x As Long  '4.2追加 列のカウンター
    Dim cnt明細行   As Long   '明細行1～5をカウントする
    Dim str転記列名 As String '日付1～5,や,場所1～5 などppの転記先テキストボックス名
    Dim ppShape     As Object 'As PowerPoint.Shape ↑の名前のシェイプを代入

    'A列が存在する間ループする
    y = 2    'A2から始めたいので 2
    PageCODE = "初回に改ページしてねの意味を込めて長文"  '本当はPageCODE ="" などで初期化
    While Len(Trim(Cells(y, "A"))) > 0  'A列のデータが存在する間、ループする
        '改ページチェック CODEが変わったか？チェックする
        If PageCODE <> Cells(y, "A") Then '保存されている値と比べ 変更されていたら
            PageCODE = Cells(y, "A")  '値を保存する※このキー値の間処理をするため保存
            'キー、基準が変わったので、改ページ処理(ひな型からコピーして増やす)
            ppひな型.Slides.Range(1).Copy  '単純に1ページ目をコピー
            DoEvents
            '新規に貼り付ける。新スライドページの作成
            Set ppSlide = pp新規.Slides.Paste   'ひな型を新プレゼンの最後に追加貼り付け
            '↑ペーストついでに、変数にセットしておくと、便利ですよ
            DoEvents
            'ページが変わったので、グループ化をセット
            ppSlide.Shapes("グループ化").TextFrame.TextRange.Text = Format(PageCODE, "mm/dd(aaaa)") 'キーをグループ化にセット
            DoEvents
            '4.3 サンプル文字を消す cnt明細行 ← 変数使いまわしはバグの元だけど
            For cnt明細行 = 1 To 5  '列見出し+1～5の項目をクリアする
                '列のループですよ、y行内で横方向に進むぞ
                For x = 1 To 99  '99列までループにして途中でExitするループ
                    str転記列名 = Trim("" & Cells(1, x)) '1行目の見出し x列で項目名を取得
                    If Len(str転記列名) = 0 Then Exit For '転記項目が無くなったら抜ける
                    
                    '転送先の項目名は、名前1～5なので、
                    str転記列名 = str転記列名 & cnt明細行  'で単純に作る。※DATA1とDATA11,15問題は考えない
                    
                    'Excelから単純にItem(項目名)でデータセット、エラーを無視して項目名無しを回避
                    On Error Resume Next  'エラーが発生しても強引に次の命令に行け
                    Set ppShape = Nothing  'これが無いと、前回オブジェクトが残る
                    Set ppShape = ppSlide.Shapes(str転記列名) 'セットするオブジェクト
                    ppShape.TextFrame.TextRange.Text = " " '4.3 スペースを1つセットでクリア
                    On Error GoTo 0  '忘れないで戻すぞ
                Next x
            Next cnt明細行
            
            '4.2 ページが変わったら、明細行も1からなので
            cnt明細行 = 1   'ppセットへ名前1にリセット 4.3ホント、ここ、忘れないでね・・・
        End If
        
        '4.2 明細のセット ↑で、作られた枠、ページにセットする
        '列のループですよ、y行内で横方向に進むぞ
        For x = 1 To 99  '99列までループにして途中でExitするループ
            str転記列名 = Trim("" & Cells(1, x)) '1行目の見出し x列で項目名を取得
            If Len(str転記列名) = 0 Then Exit For '転記項目が無くなったら抜ける
            
            '転送先の項目名は、名前1～5なので、
            str転記列名 = str転記列名 & cnt明細行  'で単純に作る。※DATA1とDATA11,15問題は考えない
            
            'Excelから単純にItem(項目名)でデータセット、エラーを無視して項目名無しを回避
            On Error Resume Next  'エラーが発生しても強引に次の命令に行け
            Set ppShape = Nothing  'これが無いと、前回オブジェクトが残る
            Set ppShape = ppSlide.Shapes(str転記列名) 'セットするオブジェクト
            ppShape.TextFrame.TextRange.Text = Cells(y, x).Text 'Excelから文字列を代入
            On Error GoTo 0  '忘れないで戻すぞ
        Next x
        
        cnt明細行 = cnt明細行 + 1  '4.2 明細のセット位置も次にするよ
        
        y = y + 1  '次の行へ※忘れて無限ループはシャレにならないよ・・・
    Wend
    
    'ひな型は閉じる、新規プレゼンは開いたまま
    ppひな型.Close
    DoEvents
    Set ppひな型 = Nothing
    
    MsgBox "処理終了、パワポで確認してください"

End Sub