ひな型スライド複数ページをコピーして使う 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,2ページ、複数のコピーを探ってみた。
Slides.Range(Array(1, 2))
Array(1, 2)不思議だけど、この1,2の指定でできました。
余談: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:１行(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.蛇足とプログラム修正方法を兼ねて
三択クイズを作りたい、そんなときは？
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の指定でできました。
これだけで、良かったのかも・・・・なんてね。
アレンジして使ってみてください。
関連する過去記事:
