パワポの複数スライドをExcelマクロを使用して１つにする ExcelのA列に入力したファイル名リストを使用してPowerPointのスライドを合体させる

複数のパワポ.pptxファイルを１つのファイルにまとめたい。

Excelマクロを使用して、
A列に入力したPowerPointファイルを開き、一つにまとめてみました。
実験動画です。コードをアレンジして使ってみてください。
#PowerPointVBA #ExcelVBA
youtu.be
https://youtu.be/7Uw9u3CbmHY
目次
00:00 0.やりたいこと
00:28 1.簡単な仕様を考えてみます。
01:42 2.単体テストまずは、A1のファイルを開いてみます
04:36 3.複数スライド1,2ページを新規プレゼンファイルにコピー
05:43 新規のプレゼン作成とタイトルセットを説明
07:11 A列のファイルを開いてスライド1,2をコピー貼り付け
09:37 実行時エラー 497 リートサーバーがないか～ DoEventsを入れて回避する
11:56 複数ファイルで実行
14:15 4.勝手に脱線全てのスライドページをコピペするには？応用編？
15:36 テストデータを更新してスライドまとめの再チェック
18:13 5.課題・問題点 A列にファイル名を記入する順番について
18:46 蛇足で宣伝前回の動画 Excel VBA ListView を紹介
21:59 バグに気が付く 1Pageしかない時に1,2をコピーした時・・・

0.やりたいこと
PowerPointのファイルを一つにまとめたい

いつもの(ぉぃぉぃ)知恵袋の質問に触発され、
detail.chiebukuro.yahoo.co.jp

＞PowerPointのファイルを一つにまとめるソフトはありますか？
＞PowerPointのファイルが50個あります
＞ファイル一つにつき2枚のスライドがあり、
＞このスライド100枚を一つのPowerPointのファイルにまとめたいです。
＞一つ一つのファイルをコピペしていたら時間がかかりすぎるので、一気にまとめる方法を探しています。
＞こうした理由で、複数のPowerPointのファイルの内容を
＞一つのPowerPointにまとめるソフトがないかご存じのかた、ご教示ください！

探せば、いくらでもあるのに、
パワーポイント初心者・素人プログラマーがツールもどきの作成を勝手に始めました。

1.簡単な仕様を考えてみます。

入力:PowerPointのファイルが50個
出力(結果):１つのファイルにまとまったPowerPointファイル

ここから、まずは、
そのPowerPointのファイルが50個がどこにあるか？
お客様じゃなかった、質問者にヒアリングしないといけないんだけど、
勝手に、作り始めます。

視聴者の声:※違う方向に行って、失敗する未来が見えた・・・

リスト管理と言えばExcelなので、
A列に50個のファイル名フルパスを記入して、
A列
D:\2023\資料001.pptx
D:\2023\資料002.pptx

それを一つにまとめてみます。

視聴者の声:
※※だからぁ、まとめるファイルが指定フォルダーに50個全て入っていて、
フォルダー指定かもしれないでしょ、仕様を詰めないとだめだよ・・・
勝手に進めちゃって・・・

2.単体テストまずは、A1のファイルを開いてみます

手前みそ紹介
ExcelからPowerPointを開きデータセット後別名保存する差し込み印刷っぽいデータ流し込みマクロの作り方
https://youtu.be/mof40MhZrYw?t=653
を参考にして、

Sub test001_セルA1のPowerPointファイルを開く()

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

    'いつもActivePresentationでやってるけど、たまには変数を使用
    Dim ppプレゼン As PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppプレゼン = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set ppプレゼン = ppApp.Presentations.Open(Range("A1")) 'A1のファイル名を開く
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If ppプレゼン Is Nothing Then
        MsgBox "Err A1パワポのファイル名、パスを確認してください", vbExclamation
        Exit Sub
    End If

    MsgBox "終了、無事に開けたか？確認してください"

End Sub

3.複数スライド1,2ページを新規プレゼンファイルにコピー

次は、スライドのコピー
これも、過去動画で何かないかなぁ・・・
PowerPoint VBA 複数スライドのコピー例題:Excel A～C,D～Fをパワポにスライド2枚単位でデータを流し込む
https://www.youtube.com/watch?v=-GVsj_kYbMI&t=172s
に

'2.2 ↑ひな型の1,2ページスライドをコピーする
'Slides.Range(Array( 番号or名前で複数指定
oPPひな型.Slides.Range(Array(1, 2)).Copy
'↑1と2のスライドをコピーする
.Slides.Range(Array(1, 2)).Copy
↑おっ、2ページ固定コピー、そのままありますね。
'2.3 Excelの行数分テンプレのスライドをコピーする
'新規のプレゼンを追加して、↑でコピーしたスライドを貼り付ける
oApp.Presentations.Add '新規追加
'テンプレートスライドを増やす
oApp.ActivePresentation.Slides.Paste 'ひな型を新プレゼンに貼り付け

.Slides.Paste で貼りつくみたいだけど、
貼り付け位置を最終、最後のページに追記したいなぁ。

で、単体テストをしてみます。

'test002_セルA列のプレゼンを開き1p2pをコピペ
Private Sub CommandButton2_Click()
    
    'PowerPointアプリの起動
    Dim ppApp As Object   'PowerPoint.Application
    Set ppApp = CreateObject("PowerPoint.Application")
    ppApp.Visible = True '可視にする
    DoEvents

    '新規の枠、新規プレゼンの作成
    Dim pp新規 As Object  'As PowerPoint.Presentation
    Set pp新規 = ppApp.Presentations.Add(WithWindow:=msoTrue) '新規追加
    'スライドの追加 レイアウトの種類 Layout:=ppLayoutTitleOnly  11
    Call pp新規.Slides.Add(Index:=1, Layout:=11)
    'タイトルをセット 一番目のオブジェクトにテキストセット
    pp新規.Slides(1).Shapes(1).TextFrame.TextRange.Text = "スライドまとめ"
    DoEvents
    
    Dim y As Long  '行カウンタ
    y = 1    'A1から始めたいので
    
    'A列のファイル名が存在する間ループする
    While Len(Trim(Cells(y, "A"))) > 0
        '開く、コピー元を変数に入れる
        Dim ppプレゼン As Object  'PowerPoint.Presentation  'pp:プレゼンテーション
        Set ppプレゼン = Nothing '初期化、エラーチェックもかねて
        On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
        Set ppプレゼン = ppApp.Presentations.Open(Trim(Cells(y, "A"))) 'A列のファイル名を開く
        DoEvents
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        '↑単純に、.Open "ファイル名" で開いただけです
        If ppプレゼン Is Nothing Then '↑上で開けたか？
            'openエラーの時、B列に開けなかったことを知らせる
            Cells(y, "B") = "オープンエラー"
        Else
            Cells(y, "B") = ""  '開けたときは空白
            '開いたプレゼンの1,2ページを固定でコピーする
            'Slides.Range(Array( 番号or名前で複数指定
            ppプレゼン.Slides.Range(Array(1, 2)).Copy
            DoEvents
            '↑1と2のスライドをコピーする
            
            '新規に貼り付ける。合体させる？
            pp新規.Slides.Paste   'ひな型を新プレゼンの最後に追加貼り付け
            DoEvents
            
            '貼り付けたので、開いたプレゼンは閉じる
            ppプレゼン.Close
            DoEvents
            Set ppプレゼン = Nothing
        End If
        
        y = y + 1  '次の行へ※忘れて無限ループはシャレにならないよ・・・
    Wend
    
    MsgBox "処理終了、パワポを確認してください"

End Sub

4.勝手に脱線全てのスライドページをコピペするには？応用編？

'Slides.Range(Array( 番号or名前で複数指定
ppプレゼン.Slides.Range(Array(1, 2)).Copy
'↑1と2のスライドをコピーする

で、１と２ページを指定してコピーしています。

質問には、書いてないけど、
全てのページをコピーするには、
ActivePresentation.Slides.Range.Copy
と、
Slides.Range(ここを指定しない)
Slides.Range.Copy
で全てコピーされます。

'test003_セルA列のプレゼンを開き全てのスライドをコピペ
Private Sub CommandButton3_Click()

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

    '新規の枠、新規プレゼンの作成
    Dim pp新規 As Object  'As PowerPoint.Presentation
    Set pp新規 = ppApp.Presentations.Add(WithWindow:=msoTrue) '新規追加
    'スライドの追加 レイアウトの種類 Layout:=ppLayoutTitleOnly  11
    Call pp新規.Slides.Add(Index:=1, Layout:=11)
    'タイトルをセット 一番目のオブジェクトにテキストセット
    pp新規.Slides(1).Shapes(1).TextFrame.TextRange.Text = "スライドまとめ"
    DoEvents

    Dim y As Long  '行カウンタ
    y = 1    'A1から始めたいので
    
    'A列のファイル名が存在する間ループする
    While Len(Trim(Cells(y, "A"))) > 0
        '開く、コピー元を変数に入れる
        Dim ppプレゼン As Object  'PowerPoint.Presentation  'pp:プレゼンテーション
        Set ppプレゼン = Nothing '初期化、エラーチェックもかねて
        On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
        Set ppプレゼン = ppApp.Presentations.Open(Trim(Cells(y, "A"))) 'A列のファイル名を開く
        DoEvents
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        '↑単純に、.Open "ファイル名" で開いただけです
        If ppプレゼン Is Nothing Then '↑上で開けたか？
            'openエラーの時、B列に開けなかったことを知らせる
            Cells(y, "B") = "オープンエラー"
        Else
            Cells(y, "B") = ""  '開けたときは空白
            '開いたプレゼン
            'Slides.Range.Copy で 全てのスライドをコピー
            ppプレゼン.Slides.Range.Copy
            DoEvents
            '↑スライドをコピーする
            
            '新規に貼り付ける。合体させる？
            pp新規.Slides.Paste   'ひな型を新プレゼンの最後に追加貼り付け
            DoEvents
            
            '貼り付けたので、開いたプレゼンは閉じる
            ppプレゼン.Close
            DoEvents
            Set ppプレゼン = Nothing
            DoEvents
        End If
        
        y = y + 1  '次の行へ※忘れて無限ループはシャレにならないよ・・・
    Wend
    
    MsgBox "処理終了、パワポを確認してください"

End Sub

5.課題・問題点 A列にファイル名を記入する順番について

話は、冒頭に戻ってしまいますが、

入力:PowerPointのファイルが50個
出力(結果):１つのファイルにまとまったPowerPointファイル

連番なら、おっさんがテストでやったみたいに、
ドラッグで連番にすればいいけど、

そのPowerPointのファイルが50個がどこにあるか？
お客様じゃなかった、質問者にヒアリングしないと

視聴者の声:※違う方向に行って、失敗する未来が見えた・・・

と、
課題や問題点を残しつつ、
実験コードをアレンジして使えるとイイなぁ・・と思いつつ・願いつつ、
逃げるように失礼します。。。。

蛇足で宣伝？
前回の動画
Excel VBA ListView の設置方法 OLEDragDropを使ってみた
https://www.youtube.com/watch?v=Z9b5dXKVKzE
で
ListViewを使用して、
ファイルエクスプローラからドロップしたファイル
A列にファイル名を書き出す
これを使ってみてください。

視聴者の声:それよりも、王道の
ファイルダイアログ（FileDialog）
をネットで検索するからいいよ。

フォルダーなら
Application.FileDialog(msoFileDialogFolderPicker)

ファイルなら
Application.FileDialog(msoFileDialogOpen)
Filters.Add "PowerPoint", "*.pptx"
みたいに使うから・・・

ですよねぇ。

以上、蛇足宣伝でした。

関連する過去記事:
ken3memo.hatenablog.com
ken3memo.hatenablog.com

複数のファイル・書類を一つの書類にまとめる作業を行う一人の男性の姿をイラストで描いてください。
Please illustrate one man working on consolidating multiple files/documents into one document.