三流君 ken3のmemo置き場

三流プログラマーのメモ書きです。主にVBAやWindowsの話題が多いです

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。

よく検索されるキーワード: [質問回答XXXXさんへ] [CreateObject] [VBA] [JRA競馬オッズ]

Excel A列~C列,D列~F列をPowerPointスライド2枚単位でデータを作成・流し込む 蛇足で三択クイズスライド

ひな型スライド複数ページをコピーして使う Slides.Range(Array(1, 2)).Copy をテスト

ExcelからPowerPointにデータをセットする解説動画の
コメント欄に
テンプレを2枚(複数)をコピーしながら、
Excel A~C,D~FをPowerPointに2枚単位でデータを流し込む、
そんな質問が書かれたので、少し探ってみます。

パワポのテンプレを2枚以上にして、同じようなことは可能なのでしょうか?
>A~Cまでを1枚目のスライド、D~Fを2枚目に流し込み、
>同じように行数分複製していくイメージです。

いつもの動画解説です、ソースコードとあわせてみてください。
youtu.be
https://youtu.be/-GVsj_kYbMI
目次
00:00 挨拶、質問内容
00:44 単体テスト 複数スライドのコピーを調べる
02:52 スライド複数コピーして新規プレゼンに貼り付け
04:24 単体の確認が終了したので、組み込んでみます。
04:45 パワポ側のテンプレートの説明
06:08 Excel to PowerPoint のテスト実行
07:21 コードの説明 デバッグ
10:38 ページ計算の説明 式・コードが複雑です
15:07 蛇足でプログラム修正方法を兼ねて三択クイズ
16:00 まず、セットするひな型スライドを作成する
19:04 セットするプログラムを修正する
21:10 テスト実行してひな型を調整する
24:13 最後に言いたかったこと Slides.Range(Array(1, 2)) です。


1.複数スライドのコピーを調べる

前回、ひな型のコピーは、バカっぽく単純に
ken3memo.hatenablog.com

    '2.3 Excelの行数分 テンプレのスライドをコピーする
    Dim n As Integer
    Dim strWORK As String
    For n = 3 To 99 'A3からデータ有無をチェックしてスライドを複製する
        'A列のデータ存在チェック
        strWORK = Trim("" & Cells(n, "A").Text)  'A列のデータを取り出し、左右の空白をカット
        If Len(strWORK) = 0 Then Exit For '文字列の長さが0 データ無しならループ処理を抜ける
        'テンプレートスライドを増やす
        oApp.ActivePresentation.Slides(1).Copy  '1ページ目をコピー
        oApp.ActivePresentation.Slides.Paste 1  '1ページ目に貼り付け
    Next n


1ページ目固定でコピー、それを同じだからって、1ページ目に貼り付け(挿入コピー)
みたいにしてたので、

今回、ひな型スライドが複数あるので、
1,2ページ、複数のコピーを探ってみた。

Slides.Range(Array(1, 2))
Array(1, 2)不思議だけど、この1,2の指定でできました。

Slides.Range Array 実行イメージ

余談:Excelのマクロ記録だと、
Sheets(Array("Sheet1", "Sheet2", "Sheet4")).Copy Before:=Sheets(6)
みたいに、名前指定かな?パワポだとスライドに名前って?と思ってたけど、

数値の1,2のページ番号・スライド番号指定で複数選択できました。

Sub スライド複数コピーして新規プレゼンに貼り付け()

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

'新規のプレゼンを追加して、↑でコピーしたスライドを貼り付ける
Application.Presentations.Add '新規追加
Dim n As Integer
For n = 1 To 5 '5セット、5回テストで貼り付ける
ActivePresentation.Slides.Paste
Next

End Sub


2.単体の確認が終了したので、組み込んでみます。

※前回(と言っても去年だけど)の動画:
https://www.youtube.com/watch?v=ZLkCiXC0FzQ
↑も合わせてみてください(↑動画コードを修正しているので詳細解説は↑も見てください。)

2.1 ひな型の確認
D:\2022\テンプレ002.pptx
に2ページのひな型を作成します。

1Page目に txtA,txtB,txtCの名前を付けたオブジェクトを作成
続いて、
2Page目に txtD,txtE,txtFの名前を付けたオブジェクトを作成

objSlide.Shapes("txtA").TextFrame.TextRange.Text = Cells(n, "A").Text 'A列
などで、使うので、事前にセットするテキストボックスに名前を付ける。

2.2 テスト実行

A~C,D~Fにデータをセットして、テスト実行する


2.3 修正したコード (説明は動画を見てください)

Option Explicit

'PowerPointのひな型をコピー後、
'Page1にA,B,C列 Page2にD,E,F列のデータをセットする
'Excel:1行(A~F列)をpp:2スライドにデータセット
'事前に作られたPowerPointのテンプレート的なスライドをコピーし作成する
Sub PowerPointテンプレ開きテキストボックスに20221022()

    Dim oApp As Object  'PowerPoint.Applicationを作成して入れる

    'PowerPoint の 起動、インターフェース用のオブジェクトを作る
    Set oApp = CreateObject("PowerPoint.Application")
    oApp.Visible = True '可視にする
    
    '2.ExcelからPowerPointへデータを流し込む
    '2.1 Excelからテンプレ.pptxを開く
    
    Const strOpenFileName = "D:\2022\テンプレ002.pptx" '元のテンプレートファイル名
    
    '元ファイルを開く テンプレートファイルを開く
    Dim oPPひな型 As Object
    Set oPPひな型 = oApp.Presentations.Open(strOpenFileName)
    '↑単純に、.Open "ファイル名" で開いただけです ファイルなしのエラーをチェックしろよコラ!!
    
    '2.2 ↑ひな型の1,2ページスライドをコピーする
    'Slides.Range(Array( 番号or名前で複数指定
    oPPひな型.Slides.Range(Array(1, 2)).Copy
    '↑1と2のスライドをコピーする
    
    '2.3 Excelの行数分 テンプレのスライドをコピーする
    '新規のプレゼンを追加して、↑でコピーしたスライドを貼り付ける
    oApp.Presentations.Add  '新規追加
    
    Dim n As Integer
    Dim strWORK As String
    For n = 2 To 999 'A2からデータ有無をチェックしてスライドを複製する 千枚も作らないよね・・
        'A列のデータ存在チェック
        strWORK = Trim("" & Cells(n, "A").Text)  'A列のデータを取り出し、左右の空白をカット
        If Len(strWORK) = 0 Then Exit For '文字列の長さが0 データ無しならループ処理を抜ける
        'テンプレートスライドを増やす
        oApp.ActivePresentation.Slides.Paste   'ひな型を新プレゼンに貼り付け
    Next n
    
    '用済みの ひな型 プレゼンファイルを閉じる
    oPPひな型.Close
    Set oPPひな型 = Nothing
    
    '2.4 Excel 1行(A列~E列) を
    '    PowerPoint 1スライド 5つのテキストボックス(タテに並べたテンプレート)
    '    データをセットする
    
    'ここからスライドをA列のデータがなくなるまで、追加する
    Dim nPAGE As Integer  'セットするスライドページ
    Dim objSlide As Object  'スライド
    For n = 2 To 999 'A2からデータ有無をチェックしてスライドにデータをセットする
        'A列のデータ存在チェック
        strWORK = Trim("" & Cells(n, "A").Text)  'A列のデータを取り出し、左右の空白をカット
        If Len(strWORK) = 0 Then Exit For '文字列の長さが0 データ無しならループ処理を抜ける
        
        'pp:スライドPage1 に Excel:A,B,C列のセット
        'スライドページの計算、1,3,5,7..と奇数ページをExcelの行から計算
        nPAGE = (n - 1) * 2 - 1 'Excel:1行目が見出しなので、n-1する。
        'pp:↑2ページ単位なので、*2で計算し、奇数ページなので-1
        Set objSlide = oApp.ActivePresentation.Slides(nPAGE)  'スライドオブジェクト
        'スライドの下にぶらさがっている、名前の付いたテキストボックスにデータセット
        objSlide.Shapes("txtA").TextFrame.TextRange.Text = Cells(n, "A").Text 'A列
        objSlide.Shapes("txtB").TextFrame.TextRange.Text = Cells(n, "B").Text
        objSlide.Shapes("txtC").TextFrame.TextRange.Text = Cells(n, "C").Text
        '↑単純に代入しただけです。ぉぃぉぃ。ループで回せよ??
        
        'pp:スライドPage2 に Excel:D,E,F列のセット
        'pp:次のページにD,E,F列をセットなので、ページ番号は+1でいいのかな。
        nPAGE = nPAGE + 1
        'pp:↑2ページ単位なので次のページは+1↓※忘れずに、スライドを再セット
        Set objSlide = oApp.ActivePresentation.Slides(nPAGE)  'スライドオブジェクト
        'スライドの下にぶらさがっている、名前の付いたテキストボックスにデータセット
        objSlide.Shapes("txtD").TextFrame.TextRange.Text = Cells(n, "D").Text
        objSlide.Shapes("txtE").TextFrame.TextRange.Text = Cells(n, "E").Text
        objSlide.Shapes("txtF").TextFrame.TextRange.Text = Cells(n, "F").Text
        '↑単純に代入しただけです。ぉぃぉぃ。ループで回せよ??
    Next n
   
    MsgBox "終了しました、パワポ未保存なので、確認後保存してね"
   
    'アプリを開きっぱなしで、ぎょうぎ悪く終わる。
    'oApp.Quit    '.QuitでoAppのPowerPoint終了
    
    '↑んっ?コードよりも、コメント行の方が行数多い?
    'たいした量のコードを書かないでも、こんなことできるんだ
    '※だって、テンプレファイル無しのエラー入ってないし、
    'txtAの名前が付いたテキストボックスが無かったときのエラー処理が入ってないじゃん
    'お金を取るプログラムなら、エラー処理入れろよ
    'と、読者の心の声が聞こえてきたので、このあたりで失礼します

End Sub



3.蛇足とプログラム修正方法を兼ねて

三択クイズを作りたい、そんなときは?

三択クイズのExcelシートイメージ

A列 B C D E F
問題 ,選択1 ,選択2 ,選択3 ,答え ,解説
と、
同じようなスライドを作りたい時

3.1 テンプレートの修正

テンプレートを修正します

3.2 プログラムの修正

セットする列とpp:名前を合わせます

※セットする名前を変えただけです、
プログラムの中身は変わっていないので、、、、参考程度に。

Sub 三択クイズ()

    Dim oApp As Object  'PowerPoint.Applicationを作成して入れる

    'PowerPoint の 起動、インターフェース用のオブジェクトを作る
    Set oApp = CreateObject("PowerPoint.Application")
    oApp.Visible = True '可視にする
    
    '2.ExcelからPowerPointへデータを流し込む
    '2.1 Excelからテンプレ.pptxを開く
    
    Const strOpenFileName = "D:\2022\テンプレ003.pptx" '元のテンプレートファイル名
    
    '元ファイルを開く テンプレートファイルを開く
    Dim oPPひな型 As Object
    Set oPPひな型 = oApp.Presentations.Open(strOpenFileName)
    '↑単純に、.Open "ファイル名" で開いただけです ファイルなしのエラーをチェックしろよコラ!!
    
    '2.2 ↑ひな型の1,2ページスライドをコピーする
    'Slides.Range(Array( 番号or名前で複数指定
    oPPひな型.Slides.Range(Array(1, 2)).Copy
    '↑1と2のスライドをコピーする
    
    '2.3 Excelの行数分 テンプレのスライドをコピーする
    '新規のプレゼンを追加して、↑でコピーしたスライドを貼り付ける
    oApp.Presentations.Add  '新規追加
    
    Dim n As Integer
    Dim strWORK As String
    For n = 2 To 999 'A2からデータ有無をチェックしてスライドを複製する 千枚も作らないよね・・
        'A列のデータ存在チェック
        strWORK = Trim("" & Cells(n, "A").Text)  'A列のデータを取り出し、左右の空白をカット
        If Len(strWORK) = 0 Then Exit For '文字列の長さが0 データ無しならループ処理を抜ける
        'テンプレートスライドを増やす
        oApp.ActivePresentation.Slides.Paste   'ひな型を新プレゼンに貼り付け
    Next n
    
    '用済みの ひな型 プレゼンファイルを閉じる
    oPPひな型.Close
    Set oPPひな型 = Nothing
    
    '2.4 Excel 1行(A列~E列) を
    '    PowerPoint 1スライド 5つのテキストボックス(タテに並べたテンプレート)
    '    データをセットする
    
    'ここからスライドをA列のデータがなくなるまで、追加する
    Dim nPAGE As Integer  'セットするスライドページ
    Dim objSlide As Object  'スライド
    For n = 2 To 999 'A2からデータ有無をチェックしてスライドにデータをセットする
        'A列のデータ存在チェック
        strWORK = Trim("" & Cells(n, "A").Text)  'A列のデータを取り出し、左右の空白をカット
        If Len(strWORK) = 0 Then Exit For '文字列の長さが0 データ無しならループ処理を抜ける
        
        'pp:スライドPage1 に Excel:A,B,C,D列のセット
        'スライドページの計算、1,3,5,7..と奇数ページをExcelの行から計算
        nPAGE = (n - 1) * 2 - 1 'Excel:1行目が見出しなので、n-1する。
        'pp:↑2ページ単位なので、*2で計算し、奇数ページなので-1
        Set objSlide = oApp.ActivePresentation.Slides(nPAGE)  'スライドオブジェクト
        'スライドの下にぶらさがっている、名前の付いたテキストボックスにデータセット
        objSlide.Shapes("問題文").TextFrame.TextRange.Text = Cells(n, "A").Text 'A列
        objSlide.Shapes("選択1").TextFrame.TextRange.Text = Cells(n, "B").Text
        objSlide.Shapes("選択2").TextFrame.TextRange.Text = Cells(n, "C").Text
        objSlide.Shapes("選択3").TextFrame.TextRange.Text = Cells(n, "D").Text
        '↑単純に代入しただけです。ぉぃぉぃ。ループで回せよ??
        
        'pp:スライドPage2 に Excel:E,F列のセット
        'pp:次のページにD,E,F列をセットなので、ページ番号は+1でいいのかな。
        nPAGE = nPAGE + 1
        'pp:↑2ページ単位なので次のページは+1↓※忘れずに、スライドを再セット
        Set objSlide = oApp.ActivePresentation.Slides(nPAGE)  'スライドオブジェクト
        'スライドの下にぶらさがっている、名前の付いたテキストボックスにデータセット
        objSlide.Shapes("答え").TextFrame.TextRange.Text = Cells(n, "E").Text
        objSlide.Shapes("解説").TextFrame.TextRange.Text = Cells(n, "F").Text
        '↑単純に代入しただけです。ぉぃぉぃ。ループで回せよ??
    Next n
   
    MsgBox "終了しました、パワポ未保存なので、確認後保存してね"
   
    'アプリを開きっぱなしで、ぎょうぎ悪く終わる。
    'oApp.Quit    '.QuitでoAppのPowerPoint終了
    
    '↑んっ?コードよりも、コメント行の方が行数多い?
    'たいした量のコードを書かないでも、こんなことできるんだ
    '※だって、テンプレファイル無しのエラー入ってないし、
    'txtAの名前が付いたテキストボックスが無かったときのエラー処理が入ってないじゃん
    'お金を取るプログラムなら、エラー処理入れろよ
    'と、読者の心の声が聞こえてきたので、このあたりで失礼します

End Sub


以上、蛇足の方が長い説明ですが、

Slides.Range(Array(1, 2))
Array(1, 2)不思議だけど、この1,2の指定でできました。
これだけで、良かったのかも・・・・なんてね。

アレンジして使ってみてください。


関連する過去記事:

ken3memo.hatenablog.com
ken3memo.hatenablog.com

Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。

  1. [VBA・マクロ プログラミング]の解説
    当店の人気はVBA系のCreateObject("XXXXXX.application")で他のアプリケーションを操作するサンプルが人気です
  2. [プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
    三流君を踏み台にする
  3. [古いクラシック ASP(Active Server Pages)]の解説。
  4. [元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。



本当に三流なんです(笑):たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り迷宮入りが多かったりします)