エクセルのデータからパワポのスライドを自動作成する方法について紹介
スライドを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.おわりのあいさつ
こんな感じで、できたかなぁ・・・
あっ、最終結果だけで、パワポはいらなかった、開きっぱなしだった・・・
う～ん、手動で閉じてください。
ぉぃぉぃ。
コードをアレンジして使ってみてください。
