ExcelからPowerPointへデータセット休日対応処理にチャレンジデバッグしてみた

ExcelからPowerPointのテンプレートへデータセットするサンプル処理をデバッグしてみます。
#ExcelVBA #PowerPointVBA #テンプレート #自動セット #マクロ

デバッグ動画です
www.youtube.com
https://www.youtube.com/watch?v=mp2Mh_69fhQ

前回までの再生リスト↓↓
https://www.youtube.com/watch?v=mjnqMrxk0qM&list=PL8vZhsyiiFhtDYDOdz94s6bQ54vwPRN-3&pp=gAQBiAQB
↑と、コメント欄のソースコードと合わせてみてください。

改善要望:

＞③元Excelの改善です。
＞連続日付けですべてイベントレコードがあれば問題ないのですが、
＞イベントの無い日付けがある場合、『本日の催事はありません』と表示を追加していです。
＞つまりレコードの日付けで抜けている日付けを見つけ行を追加する方法は難しいでしょうか

要望は、Excelファイルへ休日分のデータ追加ですが、
セット側のPowerPointを一ヶ月分作成してから、データをセットするように変更する。

1.休日用のグループを "明細0"のグループとして追加する

ひな型ファイルに
明細0
で、

＞イベントの無い日付けがある場合、『本日の催事はありません』と表示を追加していです。

『本日の催事はありません』を追加して、作成する。

2.先頭行A2のデータから月を取得して、月末までページを作成する

A2のデータが先頭なので、
ここから、処理する月を取得する。

あとは、西向く侍(2,4,6,9,11)とか、いろいろあるけど、
月末までの枚数、ひな型を先にコピーする。

2.1 ひな型ファイルを開き可視と不可視の切り替え

ひな型ファイルを開いたら、
明細0を可視にして、
明細1～5を不可視にする。

※全て、イベント無し、『本日の催事はありません』と表示だけにする

2.2 月末まで、データを作成する(ひな型をコピーする)

月末まで、データをコピーする

コピー後、
テキストボックス "右上グループ" に、
日付をセットする。
※ここを、後処理でファイル名として使用するので、注意

3. セット位置の修正

1日から月末まで、PowerPoint側に枠が作成されたので、
日付のページに明細データをセットするように細工する。

2023/08/03 なら、3ページ目
2023/08/12 なら、12ページ目

まぁ、1ページ1日なので、そんなに工夫はしないけど。
※これが、あとあと、(1日2ページの場合があって)まずいんだけど・・

データがあるので、
このタイミングで明細0を不可視にして、
イベント無し、『本日の催事はありません』を消す。
不可視にして見えなくする小細工

'3.Excelデータのセット
'1日から月末まで､PowerPoint側に枠が作成されたので､
'日付のページに明細データをセットするように細工する｡
'2023/08/03 なら、3ページ目
'2023/08/12 なら、12ページ目
Sub 総合テスト20230822_002Excelデータのセット()

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

    'ひな型ファイルを開く
    Dim strPPFName As String
    strPPFName = ActiveWorkbook.Path & "\ひな型0823.pptx"  '※Excelと同じ場所を開く
    
    '開く、コピー元を変数に入れる
    Dim ppひな型 As Object  'PowerPoint.Presentation  'pp:プレゼンテーション
    Set ppひな型 = Nothing '初期化、エラーチェックもかねて
    On Error Resume Next   '↓でSet 取得エラー時に次へ ファイルが開けなかった時
    Set ppひな型 = ppApp.Presentations.Open(strPPFName, msoTrue) 'リードオンリーで開く
    DoEvents
    On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
    '↑単純に、.Open "ファイル名" で開いただけです
    If ppひな型 Is Nothing Then '↑上で開けたか？
        'openエラーの時、開けなかったことを知らせる
        MsgBox strPPFName & "が開けません確認してください", vbExclamation
        Exit Sub  'んっ？空のppAppが残るか、これだと・・・
    End If

    Dim ppSlide As Object  'As PowerPoint.Slide
    Set ppSlide = ppひな型.Slides(1) 'ひな型の1ページ目を使用したいので
    
    'ひな型の初期設定、明細0を可視、明細1～5を不可視にする
    ppSlide.Shapes("明細0").Visible = True '可視にする、初期は予定無しを表示
    '明細1～5行を非表示にする
    Dim cnt明細行 As Integer
    For cnt明細行 = 1 To 5  '明細行を非表示にする
        ppSlide.Shapes("明細" & cnt明細行).Visible = False '不可視にする
    Next cnt明細行

    '月末まで、枠をコピーして作成する
    Dim yy As Integer
    Dim mm As Integer
    Dim dd As Integer
    Dim 処理年月日 As Date
    
    yy = Year(Range("A2").Value)  'A2の日付から取得
    mm = Month(Range("A2").Value)
    dd = 1  '1日固定。※A2に2023/08/02と二日からスタートでも、1を固定代入
    処理年月日 = DateSerial(yy, mm, dd) 'スタート初日、処理する日付を求める

    For dd = 1 To 31  '最大31日
        'テンプレートのコピー
        If dd <> 1 Then  '初日以外は、コピペする。
            ppひな型.Slides.Range(1).Copy  '単純に1ページ目をコピー
            DoEvents
            '新規に貼り付ける。新スライドページの作成
            Set ppSlide = ppひな型.Slides.Paste  'プレゼンの最後に追加貼り付け
            '↑ペーストついでに、変数にセットしておくと、便利ですよ
            DoEvents
        End If

        '右上に日付をセットする
        ppSlide.Shapes("右上グループ").TextFrame.TextRange.Text = Format(処理年月日, "mm/dd(aaa)")
        '↑ひな型・テンプレートに付けた名前

        '次の日にする
        処理年月日 = DateAdd("d", 1, 処理年月日) '+1日で次の日にする
        If Month(処理年月日) <> mm Then '月が変わったらループを抜けるぞ
            Exit For
        End If
    
    Next dd
    
    'Excelのデータをセットする 2023/08/23修正
    Dim y As Long  '行カウンタ
    Dim PageCODE  As Variant  'この値がキーが変更されたら改ページする
    
    Dim x As Long  '列のカウンター
    Dim str転記列名 As String 'Excelの見出し など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")  '値を保存する※このキー値の間処理をするため保存
            'キー、基準が変わったので、セットするページを移動する
            dd = Day(PageCODE)  'PageCODEの日がページなので、day関数でセット位置
            Set ppSlide = ppひな型.Slides(dd)  '変数に代入する
            ppSlide.Shapes("明細0").Visible = False '明細0予定なしを不可視にして消す
            DoEvents
            
            'ページが変わったら、明細行も1からなので
            cnt明細行 = 1   'ppセットへ名前1にリセット ホント、ここ、忘れないでね・・・
        End If
        
        '明細のセット ↑で、作られた枠、ページにセットする
        '3.4.1 まず、セットする明細を可視にする
        ppSlide.Shapes("明細" & cnt明細行).Visible = True '明細行を表示する
        
        '3.4.2 Excel1行をPowerPointテンプレ 明細XXのグループにセットする
        '列のループですよ、y行内で横方向に進むぞ
        For x = 1 To 99  '99列までループにして途中でExitするループ
            str転記列名 = Trim("" & Cells(1, x)) '1行目の見出し x列で項目名を取得
            If Len(str転記列名) = 0 Then Exit For '転記項目が無くなったら抜ける
  
            'Excelから単純にItem(項目名)でデータセット、エラーを無視して項目名無しを回避
            On Error Resume Next  'エラーが発生しても強引に次の命令に行け
            Set ppShape = Nothing  'これが無いと、前回オブジェクトが残る
            'Shapes("明細XX").GroupItems("XXXXX")でアクセスする
            '詳細は単体テスト https://www.youtube.com/watch?v=XoNR5YrdtDQ を見てね
            Set ppShape = ppSlide.Shapes("明細" & cnt明細行).GroupItems(str転記列名)
            '↑セットするオブジェクトを 明細1行のグループ内の項目名で探す
            
            ppShape.TextFrame.TextRange.Text = Cells(y, x).Text 'Excelから文字列を代入
            DoEvents
            On Error GoTo 0  '忘れないで戻すぞ
        Next x
        
        cnt明細行 = cnt明細行 + 1  '明細のセット位置も次にするよ
        
        y = y + 1  '次の行へ※忘れて無限ループはシャレにならないよ・・・
        
    Wend

    MsgBox "処理終了、データのセットを確認してください"

End Sub

4.開いているPowerPointスライドからjpgファイルを作成する

データ確認後、
PowerPointスライドからjpgファイルを作成する

＞①以前ｊｐｇに変換をお願いして反映をしていただきましたが、
＞Excelからｐｐｔ変換したところで、
＞ｐｐｔの状態で修正が必要な場合があります。
＞よって、現在展開されたソースコードをｐｐｔ展開完了してそのまま
＞開いた状態で終了したソースでまとめたいです。
＞ｐｐｔが完成したところで別マクロでｊｐｇ保存へ展開していたいので
＞ソースを別でご教授いただければ幸いです。

スライドのシェイプ "右上グループ" をファイル名にして、
jpgファイルを作成する

'4.開いているPowerPointスライドからjpgファイルを作成する
'スライドのシェイプ"右上グループ"をファイル名にして、
'jpgファイルを作成する
Sub 総合テスト20230823_003ppスライドからjpg作成()

    '起動済みのパワポを捕まえる
    Dim ppApp As Object
    
    Set ppApp = Nothing
    On Error Resume Next  'エラーが発生しても強引に次の命令に行け
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0  '忘れないで戻すぞ

    If ppApp Is Nothing Then
        MsgBox "パワポが見つかりません"
        Exit Sub
    End If
    
    'スライドからjpgを作成する
    
    Dim p As Integer  'pp:スライドのページ
    
    Dim ppSlide As Object  'PowerPoint.Slide  'スライド
    Dim ppShape As Object  'PowerPoint.Shape  'シェイプ
    
    'プレゼンスライドのループ 1ページから最終ページまでループ
    For p = 1 To ppApp.ActivePresentation.Slides.Count
        Set ppSlide = ppApp.ActivePresentation.Slides(p)
        
        '2023/06/25 現在のページをjpgに保存する
        '詳細は https://www.youtube.com/watch?v=xWqXdxGE8XU を見てください。
        
        
        'Excelから単純にItem(右上グループ)でデータ取得、エラー項目名無し※ファイル名無し判断
        On Error Resume Next  'エラーが発生しても強引に次の命令に行け
        Set ppShape = Nothing  'これが無いと、前回オブジェクトが残る
        Set ppShape = ppSlide.Shapes("右上グループ")
        '↑ここの日付をファイル名にする
        Dim MMDD As String
        MMDD = "" 'ここも空文字""で初期化
        MMDD = ppShape.TextFrame.TextRange.Text '"右上グループ"シェイプから文字列を代入
        DoEvents
        On Error GoTo 0  '忘れないで戻すぞ
        
        If MMDD <> "" Then  '右上のデータアリの時、jpgを作成する
            Dim strJPGFILENAME As String  '保存ファイル名
            '現在のExcelの場所\MM/DD(aaa)にしたいけど、半角/はダメですよ
            strJPGFILENAME = ActiveWorkbook.Path & "\" & StrConv(MMDD, vbWide) & ".jpg"
            '06/25(日)を↑StrConv(YYMM, vbWide)で０６/２５（日）と全角にする
            '↓で保存するときにファイル名に半角/スラッシュがNGなので
            ppSlide.Export strJPGFILENAME, "jpg"
            '↑単純に、.Exportで作成する
        End If
    
    Next p
    
    MsgBox "jpg作成終了、ファイルを確認してください"

End Sub