A列の日付が変わるまで(グループ化)
最大5件のデータを事前に用意したPowerPointひな型テンプレートにセットする。
↑あっ、勝手に最大5件にして、あとでトラブル発生パターンを作る気満々で・・・
youtu.be
https://youtu.be/tprejIA-Q-M
目次とソースコード
00:00 やりたいこと 1.要求仕様:下記の質問をいただく
00:54 2.仕様をまとめる:入力と出力を考える
02:23 3.テンプレートファイルを作成する
03:13 4.1 1日単位で1スライドを作成
10:02 4.2 明細行 1～5のデータのセット 列名+連番の名前にデータをセットする
15:34 4.3 余った、行を消す じゃなくて、先に消してからセットする
22:55 5.終わりの挨拶 納品
24:20 5.1 テストデータを追加 5件以上のテスト 不具合バグの確認
27:00 5.2 勝手に5件以上あると想像したけど、実際は無かったりもするし・・・
29:00 閃いて修正に入り、ハマる・・・思い付きは・・・
32:32 6件以上の複数ページをわかりやすく？
36:52 余計な修正をやって伝書バトSEに怒られる 勝手にA列を変えて応用説明
1.要求仕様:下記の質問をいただく
質問、お題をいただく。
A列 日付
B列 名前
C列 会場
D列 時間
E列 イベント名A列の日付事に1～5前後レコードがあり一か月分の情報があります。
これらを日付事にPowerPointのテキストボックスに貼付け転記をします。
上記の繰り返しで日付事1日分の複数のレコードに1シートに作成、2日目を追加シート増やします。
日付は一か月分のレコードになります。これらの作業をExcelマクロを実行しPowerPointテキストボックスに転記する作業になります。
2.仕様をまとめる:入力と出力を考える
ExcelからPowerPointへデータを差し込む処理
使用するデータ
日付
名前
会場
開始時間
イベント名
入力イメージ:A列から明細行で1行単位
出力イメージ:1スライド5件に差し込む
入力データ:Excel
A列,B列,C列,D列,E列
日付,名前,会場,開始時間,イベント名
6/1,AA,あいう,10:00,音楽ライブ
6/1,BB,かきく,11:00,サッカー
6/2,CC,さしす,12:00,就職説明会
6/2,BB,かきく,13:00,就職説明会
6/2,AA,あいう,14:00,就職説明会
6/2,FF,んんん,15:00,就職説明会
6/3,XX,ををを,16:00,フットサル
出力:PowerPoint 1スライド 5件
1スライド目
日付,名前,会場,開始時間,イベント名
6/1,AA,あいう,10:00,音楽ライブ
6/1,BB,かきく,11:00,サッカー
2スライド目
日付,名前,会場,開始時間,イベント名
6/2,CC,さしす,12:00,就職説明会
6/2,BB,かきく,13:00,就職説明会
6/2,AA,あいう,14:00,就職説明会
6/2,FF,んんん,15:00,就職説明会
3スライド目
日付,名前,会場,開始時間,イベント名
6/3,XX,ををを,16:00,フットサル
3.テンプレートファイルを作成する
テンプレートファイルを
d:\テンプレート\
に
テンプレ0620.pptx
で作成する。
スライド内に項目名+1～5のテキストボックスを作成する
日付,名前,会場,開始時間,イベント名
日付1,名前1,会場1,開始時間1,イベント名1
日付2,名前2,会場2,開始時間2,イベント名2
・
・
日付5,名前5,会場5,開始時間5,イベント名5
とりあえず、固定の場所、固定の名前で作成。
※固定の場所だったり、Excelと同じ場所とかルールを決めて運用する人達が多いかな。
(ルール、仕様を決めるのって、センスがでるよなぁ・・・)
テンプレートファイルの名前の付け方、操作は過去記事:
ken3memo.hatenablog.com
↑を参考にして作って下さい。
4.テンプレートファイルを開き データをセットする
A列のグループが変わるまでパワポのテンプレにセットする
A列の日付が変わるまで(グループ化)
最大5件のデータを事前に用意したPowerPointひな型テンプレートにセットする。
↑あっ、勝手に最大5件にして、あとでトラブル発生パターンを作る気満々で・・・
これも、センスが問われる、
コントロールブレーク処理かなぁ。
4.1 1日単位で1スライドを作成
A列の値が変わるまで、これをブレーク基準にすることから始めますか。
仕様:A列のデータが変わったら、新しいスライドをパワポに追加する
A列,B,C,D,E....
日付,名前,会場,開始時間,イベント名
6/1,山田,グリーンホール,9:30,ピアノコンサート
6/1,中村,ブルーパーク,10:45,バスケットボー
・
・
6/13,中田,カルシウムカフェ ,10:45,チーズテイスティング
6/14,加藤,カリウム公園 ,10:15,バナナフェスティバル
6/14,小野,ナトリウム通り ,11:45,ラーメン食べ放題
6/15,松田,カーボン博物館 ,10:30,生命の歴史
結果:日付別にスライドが作成される
Sub A列でコントロールブレイク001ひな型コピーテスト() 'PowerPointアプリの起動 Dim ppApp As Object 'PowerPoint.Application Set ppApp = CreateObject("PowerPoint.Application") ppApp.Visible = True '可視にする DoEvents 'ひな型ファイルを開く Dim strPPFName As String 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) '新規追加 Dim ppSlide As Object 'As PowerPoint.Slide Dim y As Long '行カウンタ Dim PageCODE As Variant 'この値がキーが変更されたら改ページする '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 'ページが変わったので、タイトルをセット ppSlide.Shapes("タイトル 1").TextFrame.TextRange.Text = PageCODE 'キーをタイトルにセット DoEvents End If '明細のセット ↑で、作られた枠、ページにセットする y = y + 1 '次の行へ※忘れて無限ループはシャレにならないよ・・・ Wend 'ひな型は閉じる、新規プレゼンは開いたまま ppひな型.Close DoEvents Set ppひな型 = Nothing MsgBox "処理終了、パワポで確認してください" End Sub
4.2 明細行 1～5のデータのセット 列名+連番の名前にデータをセットする
仕様:列名+連番の名前にデータをセットする
A列,B,C,D,E....
日付,名前,会場,開始時間,イベント名
6/1,山田,グリーンホール,9:30,ピアノコンサート
6/1,中村,ブルーパーク,10:45,バスケットボー
結果:列名+連番でパワーポイントの
日付1,名前1,会場1,開始時間1,イベント名1
日付2,名前2,会場2,開始時間2,イベント名2
・
・
日付5,名前5,会場5,開始時間5,イベント名5
にデータがセットされる。
10:02 4.2 明細行 1～5のデータのセット 列名+連番の名前にデータをセットする
https://www.youtube.com/watch?v=tprejIA-Q-M&t=602s&list=PL8vZhsyiiFhtDYDOdz94s6bQ54vwPRN-3&index=1&t=1299s&pp=gAQBiAQB
↑が解説場所です、動画結果と下記のソースコードを合わせて見てください。
'明細データのセット ' https://ken3memo.hatenablog.com/entry/2022/04/25/190000 'を参考に、明細行1～5へデータをセットする Sub A列でコントロールブレイク002明細行のセット() 'PowerPointアプリの起動 Dim ppApp As Object 'PowerPoint.Application Set ppApp = CreateObject("PowerPoint.Application") ppApp.Visible = True '可視にする DoEvents 'ひな型ファイルを開く Dim strPPFName As String 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) '新規追加 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 'ページが変わったので、タイトルをセット ppSlide.Shapes("タイトル 1").TextFrame.TextRange.Text = PageCODE 'キーをタイトルにセット DoEvents '4.2 ページが変わったら、明細行も1からなので cnt明細行 = 1 'ppセットへ名前1にリセット 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 '次の行へ※忘れて無限ループはシャレにならないよ・・・ Wend 'ひな型は閉じる、新規プレゼンは開いたまま ppひな型.Close DoEvents Set ppひな型 = Nothing MsgBox "処理終了、パワポで確認してください" End Sub
参考過去記事:
ken3memo.hatenablog.com
4.3 余った、行を消す じゃなくて、先に消してからセットする
仕様:2件データをセットしたら、残りの3件(5-2)を消す
テンプレートが5行固定なので、
セットしない場所のデータをスペースでクリアする。
デバッグ時の見た目から、
残りの3件(5-2)を消す↑と、考えると大変。
仕様書を書く人のセンスが悪いと、大変だね・・・
仕様:テンプレートからページをコピーして追加後、先に1～5をクリアする
↑の方が、自然な流れですね。
残りのゴミデータを消すじゃなくて、
先にキレイニしてから書き込む。
まぁ、こんな感じで、仕様を考えるのって大事なんですよ。
なんて、センス無しの私が言うと説得力ないけどね。
(告白:始め余りを消すコードFor n=明細行+1 To 5のループを考えてました、
でも、ぴったり5で止まった時は、あっ5+1=6 to 5だからいいのか？
など、
しばらくして、作成中に先に消せばいいことに気が付く)
(創作:さらに、動画を撮る前に、
そもそもテンプレートが空白なら、サンプル文字を入れるな、
と、激怒する先輩？が物語的にはありかなぁ？なんて思ったり。)
15:34 4.3 余った、行を消す じゃなくて、先に消してからセットする
https://www.youtube.com/watch?v=tprejIA-Q-M&t=934s&list=PL8vZhsyiiFhtDYDOdz94s6bQ54vwPRN-3&index=1&t=1299s&pp=gAQBiAQB
↑が解説場所です、動画結果と下記のソースコードを合わせて見てください。
'4.3 スライド追加後、テンプレのサンプル文字を消す '明細行が余った時、ゴミデータが残るので、1～5を先に消す Sub A列でコントロールブレイク003サンプル文字を先に削除() 'PowerPointアプリの起動 Dim ppApp As Object 'PowerPoint.Application Set ppApp = CreateObject("PowerPoint.Application") ppApp.Visible = True '可視にする DoEvents 'ひな型ファイルを開く Dim strPPFName As String 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) '新規追加 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 'ページが変わったので、タイトルをセット ppSlide.Shapes("タイトル 1").TextFrame.TextRange.Text = PageCODE 'キーをタイトルにセット 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 '次の行へ※忘れて無限ループはシャレにならないよ・・・ Wend 'ひな型は閉じる、新規プレゼンは開いたまま ppひな型.Close DoEvents Set ppひな型 = Nothing MsgBox "処理終了、パワポで確認してください" End Sub
5.終わりの挨拶 納品
やっと、完成したかなぁ。
納品完了。
視聴者の心の声:何か忘れてない？
あっ、忘れてた。
A列の日付が変わるまで(グループ化)
最大5件のデータを事前に用意したPowerPointひな型テンプレートにセットする。
↑あっ、勝手に最大5件にして、あとでトラブル発生パターンを作る気満々で・・・
5.1 テストデータを追加 5件以上のテスト
蛇足でAIを使って、テストデータを作成する実演
※もし動画録画中に混みあってて、応答時間が見えないから止めときゃいいのに・・・
データを貼り付けて、実行すると、
まぁ、そうなるよね。。。。
5.2 勝手に5件以上あると想像したけど、実際は無かったりもするし・・・
要求時の打ち合わせ
＞A列の日付事に1～5前後レコードがあり一か月分の情報があります。
＞これらを日付事にPowerPointのテキストボックスに貼付け転記をします。
日付事に1～5前後レコードがあり
ここ、よくある日本語だよね・・・・
わざと、大袈裟に想像して※トラブルを創造して
作った架空の話だけど、
システム開発アルアルかなぁ。
通常は、5件以上は無いんだけど、
大晦日やクリスマスなど24時間イベント稼働・・とか、
打ち合わせ後に、後から気が付いたり。
誰でも自称SEと言えるこの時代、
ア.プロなら危ない所は事前につぶす？コーダーと違うのでそれが高給取りのSEですよ。。
イ.イヤイヤ仕様です、と、突っぱねる。交渉力もSEに必要な能力です。ぉぃぉぃ
ウ.作るのは下の人達や外注だから、そのまま仕様変更を下に流す、SE=劣化伝書鳩です
エ.その他
と、
スッキリしないところで、次回かなぁ。
※質問、感想待ってます、気軽にコメント欄へ
プログラムのアレンジ、
修正処理の流れで、
1つでも参考となればうれしいです。
27:00 5.2 勝手に5件以上あると想像したけど、実際は無かったりもするし・・・
https://www.youtube.com/watch?v=tprejIA-Q-M&t=1620s&list=PL8vZhsyiiFhtDYDOdz94s6bQ54vwPRN-3&index=1&t=1299s&pp=gAQBiAQB
↑が解説場所です、動画結果と下記のソースコードを合わせて見てください。
29:00 閃いて修正に入り、ハマる・・・思い付きは・・・
32:32 6件以上の複数ページをわかりやすく？
36:52 余計な修正をやって伝書バトSEに怒られる 勝手にA列を変えて応用説明
'蛇足 '思い付きで、いろいろとやってみた。 Sub A列でコントロールブレイク005蛇足で伝書鳩SEと戦う() 'PowerPointアプリの起動 Dim ppApp As Object 'PowerPoint.Application Set ppApp = CreateObject("PowerPoint.Application") ppApp.Visible = True '可視にする DoEvents 'ひな型ファイルを開く Dim strPPFName As String 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) '新規追加 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 ↑の名前のシェイプを代入 Dim cntGroup As Long 'A列が存在する間ループする y = 2 'A2から始めたいので 2 PageCODE = "初回に改ページしてねの意味を込めて長文" '本当はPageCODE ="" などで初期化 While Len(Trim(Cells(y, "A"))) > 0 'A列のデータが存在する間、ループする '改ページチェック CODEが変わったか？チェックする If PageCODE <> Cells(y, "A") Or cnt明細行 = 6 Then '保存されている値と比べ 変更されていたら If PageCODE = Cells(y, "A") Then cntGroup = cntGroup + 1 Else cntGroup = 1 End If PageCODE = Cells(y, "A") '値を保存する※このキー値の間処理をするため保存 'キー、基準が変わったので、改ページ処理(ひな型からコピーして増やす) ppひな型.Slides.Range(1).Copy '単純に1ページ目をコピー DoEvents '新規に貼り付ける。新スライドページの作成 Set ppSlide = pp新規.Slides.Paste 'ひな型を新プレゼンの最後に追加貼り付け '↑ペーストついでに、変数にセットしておくと、便利ですよ DoEvents 'ページが変わったので、タイトルをセット If cntGroup = 1 Then ppSlide.Shapes("タイトル 1").TextFrame.TextRange.Text = PageCODE 'キーをタイトルにセット Else ppSlide.Shapes("タイトル 1").TextFrame.TextRange.Text = PageCODE & " Page-" & cntGroup 'キ ーをタイトルにセット End If 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 '次の行へ※忘れて無限ループはシャレにならないよ・・・ Wend 'ひな型は閉じる、新規プレゼンは開いたまま ppひな型.Close DoEvents Set ppひな型 = Nothing MsgBox "処理終了、パワポで確認してください" End Sub
関連過去記事:
