パワポ マクロ JPG／PDF出力 Slide Export ファイル名 "pdf" エクセルからパワポのテンプレートへデータセット後 jpgやPDFを作成

エクセルのデータからパワポのスライドを自動作成する方法について紹介
スライドをjpgやpdfで出力する方法をコードで示す。
#PowerPointVBA #PDF出力 #自動作成 #JPG出力

キーワード:
エクセル,パワポ,自動作成,出力,jpg,pdf,修正情報

YouTubeのタイトル案を3つ:

• エクセルからパワポに自動変換！スライドをjpgやpdfで保存する方法
• 視聴者の質問に答えます！エクセルデータからパワポスライドを作って画像やPDFに出力するコード
• エクセルとパワポの連携術！スライドの自動作成と出力

www.youtube.com
https://www.youtube.com/watch?v=xWqXdxGE8XU
目次:
00:00 あいさつ、不具合内容と修正依頼
00:28 1.Slides(p).Export strFILENAME, "jpg"で可能？
01:38 2.現在の処理にJPG出力を組み込む
06:37 3.おまけで、PDF出力
09:55 4.おわりのあいさつ

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

＞③最終的に日付ごとに分けたページを1枚ごとに月日の名前でｊｐｇとして
＞保存したいです。

1.Slides(p).Export strFILENAME, "jpg"で可能？

私のサイトの似ている処理は、
PowerPoint 全てのスライドをjpg画像で出力 VBA マクロ .Exportで簡単にできました
https://ken3memo.hatenablog.com/entry/2022/05/06/123000
を見ると、
Slides(p).Export strFILENAME, "jpg"
で、できそうです。

'3.ループで回して1ページ目からスライドを.Exportで画像出力
Sub test003()
    Dim strPATH As String  '保存場所 現在と同じPATHにしたい
    strPATH = ActivePresentation.Path  '保存場所パス
    
    Dim strFILENAME As String  '出力ファイル名
    Dim p As Integer
    
    For p = 1 To ActivePresentation.Slides.Count
        strFILENAME = strPATH & "\YouTubeサムネ" & Format(p, "000") & ".jpg"
        'Slides(p)をjpg画像出力
        ActivePresentation.Slides(p).Export strFILENAME, "jpg"
        '↑pページ目のスライドをjpg出力
    Next
    
    MsgBox "終了"
    
End Sub

2.現在の処理に組み込む

チョット安易だけど、
Yが次に進んだ、ループを抜ける前に、
グループAが変化したか？チェックして、
変わったときに、JPG出力してます。

        y = y + 1  '次の行へ※忘れて無限ループはシャレにならないよ・・・
        
        '↑で、次の行に移動する。ここでグループが変わったら、
        If PageCODE <> Cells(y, "A") Then '保存されている値と比べ 変更されていたら
            '2023/06/25 現在のページをjpgに保存する
            Dim YYMM As String
            YYMM = Format(PageCODE, "mm/dd(aaa)") 'A列日付の分類をファイル名にする
            Dim strJPGFILENAME As String  '保存ファイル名
            '現在のExcelの場所\MM/DD(aaa)にしたいけど、半角/はダメですよ
            strJPGFILENAME = ActiveWorkbook.Path & "\" & StrConv(YYMM, vbWide) & ".jpg"
            '06/25(日)を↑StrConv(YYMM, vbWide)で０６/２５（日）と全角にする
            '↓で保存するときにファイル名に半角/スラッシュがNGなので
            ppSlide.Export strJPGFILENAME, "jpg"
            '↑単純に、.Exportで作成する
        End If

ポイントは、特になく、
YYMM = Format(PageCODE, "mm/dd(aaa)") 'A列日付の分類をファイル名にする
StrConv(YYMM, vbWide)
で、全角にしただけかなぁ。
※本当は、半角がいいんだけど、半角/スラッシュがファイル名で使えないので。

'パワポのテンプレートにデータをセット後
'A列の値が変化したら、
'A列日付をファイル名にして、jpgファイルとしてパワポのスライドを保存する
Sub デバッグ20230625_03Aデータセット後JPG保存()

    '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
            'ページが変わったので、グループ化をセット ※2023/06/25 グループ・分類をセットする時に使ってね
            'ppSlide.Shapes("グループ化").TextFrame.TextRange.Text = Format(PageCODE, "mm/dd(aaa)")
            '↑コメントアウト、現在は日付1が右上なので、未使用
            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  '次の行へ※忘れて無限ループはシャレにならないよ・・・
        
        '↑で、次の行に移動する。ここでグループが変わったら、
        If PageCODE <> Cells(y, "A") Then '保存されている値と比べ 変更されていたら
            '2023/06/25 現在のページをjpgに保存する
            Dim YYMM As String
            YYMM = Format(PageCODE, "mm/dd(aaa)") 'A列日付の分類をファイル名にする
            Dim strJPGFILENAME As String  '保存ファイル名
            '現在のExcelの場所\MM/DD(aaa)にしたいけど、半角/はダメですよ
            strJPGFILENAME = ActiveWorkbook.Path & "\" & StrConv(YYMM, vbWide) & ".jpg"
            '06/25(日)を↑StrConv(YYMM, vbWide)で０６/２５（日）と全角にする
            '↓で保存するときにファイル名に半角/スラッシュがNGなので
            ppSlide.Export strJPGFILENAME, "jpg"
            '↑単純に、.Exportで作成する
        End If
    Wend
    
    'ひな型は閉じる、新規プレゼンは開いたまま
    ppひな型.Close
    DoEvents
    Set ppひな型 = Nothing
    
    MsgBox "処理終了、パワポで確認してください"

End Sub

3.おまけで、PDF出力

視聴者からの要望は、jpgで終わりなのに、
おまけで、PDF出力
のテスト。
と言っても、Slide.Export "ファイル名", "pdf" にしただけ・・・

            '現在のExcelの場所\MM/DD(aaa)にしたいけど、半角/はダメですよ
            strPDFFILENAME = ActiveWorkbook.Path & "\" & StrConv(YYMM, vbWide) & ".pdf"
            '06/25(日)を↑StrConv(YYMM, vbWide)で０６/２５（日）と全角にする
            '↓で保存するときにファイル名に半角/スラッシュがNGなので
            ppSlide.Export strPDFFILENAME, "pdf"
            '↑単純に、.Exportで作成する

↑名前をPDFに変更しただけ・・ぉぃぉぃ

PDFを入れておくと、検索にひっかかるかなぁ・・・と思って。
そんなに甘くないよねぇ・・・

'パワポのテンプレートにデータをセット後
'A列の値が変化したら、
'A列日付をファイル名にして、pdfファイルとしてパワポのスライドを保存する
'ファイルの拡張子を変えただけ・・・
Sub デバッグ20230625_03Bデータセット後PDF保存()

    '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
            'ページが変わったので、グループ化をセット ※2023/06/25 グループ・分類をセットする時に使ってね
            'ppSlide.Shapes("グループ化").TextFrame.TextRange.Text = Format(PageCODE, "mm/dd(aaa)")
            '↑コメントアウト、現在は日付1が右上なので、未使用
            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  '次の行へ※忘れて無限ループはシャレにならないよ・・・
        
        '↑で、次の行に移動する。ここでグループが変わったら、
        If PageCODE <> Cells(y, "A") Then '保存されている値と比べ 変更されていたら
            '2023/06/25 現在のページをjpgに保存する
            Dim YYMM As String
            YYMM = Format(PageCODE, "mm/dd(aaa)") 'A列日付の分類をファイル名にする
            Dim strPDFFILENAME As String  '保存ファイル名
            '現在のExcelの場所\MM/DD(aaa)にしたいけど、半角/はダメですよ
            strPDFFILENAME = ActiveWorkbook.Path & "\" & StrConv(YYMM, vbWide) & ".pdf"
            '06/25(日)を↑StrConv(YYMM, vbWide)で０６/２５（日）と全角にする
            '↓で保存するときにファイル名に半角/スラッシュがNGなので
            ppSlide.Export strPDFFILENAME, "pdf"
            '↑単純に、.Exportで作成する
        End If
    Wend
    
    'ひな型は閉じる、新規プレゼンは開いたまま
    ppひな型.Close
    DoEvents
    Set ppひな型 = Nothing
    
    MsgBox "処理終了、パワポで確認してください"

End Sub

4.おわりのあいさつ

こんな感じで、できたかなぁ・・・

あっ、最終結果だけで、パワポはいらなかった、開きっぱなしだった・・・
う～ん、手動で閉じてください。
ぉぃぉぃ。

コードをアレンジして使ってみてください。