XXXXXさんへ ExcelからPowerPoint連続設定自動画面切り替え秒数の設定を Excelから連続で行う VBA マクロデバッグ

Excel A列に切替タイミングの秒数を入力、PowerPointの画面切り替えタイミングにセットする
そんな処理を行ってみます。

Youtubeのコメント欄で下記の質問をいただきました

パワーポイントの自動画面切り替えの秒数の設定において、エスセルに記入した秒数を流し込むことは
可能でしょうか。
パワーポイントのスライドが600ページ✖️4セットあり、それぞれ表示する秒数がエクセルにまとめてあ
ります。
これを手打ちしていく作業がなかなか大変なので、効率的な（自動化できる）方法があればご教示いた
だけると更新です。
宜しくお願い致します。

下記、いつものあのあの説明動画です
youtu.be
https://youtu.be/QHOxiX9NbDk
目次
00:00 0.やりたいこと
00:50 1.単体テスト SlideShowTransition.AdvanceTime = 5 なとで設定可能
03:55 2.Excelの切り替え秒数リストからセットする
09:42 3.蛇足の修正説明

1.単体テスト SlideShowTransition.AdvanceTime = 5 なとで設定可能

VBA powerpoint 画面切り替えタイミングで検索すると、

SlideShowTransition オブジェクト (PowerPoint)
https://docs.microsoft.com/ja-jp/office/vba/api/powerpoint.slideshowtransition
docs.microsoft.com
が見つかり、そこから、

SlideShowTransition.AdvanceOnTime プロパティ (PowerPoint)
https://docs.microsoft.com/ja-jp/office/vba/api/powerpoint.slideshowtransition.advanceontime
一定の時間が経過した後に指定したスライドを自動的に切り替えるかどうかを指定します。値の取得
と設定が可能です

例
次の使用例は、アクティブなプレゼンテーションのスライド 1 を 5— 秒経過した後、またはマウスが

クリックされた後に進むか、最初にマウスがクリックされた場合に設定します。

With ActivePresentation.Slides(1).SlideShowTransition

    .AdvanceOnClick = msoTrue

    .AdvanceOnTime = msoTrue

    .AdvanceTime = 5

End With

↑この公式の例がズバリですね。

イミディエイトでテストしてみた
? ActivePresentation.Slides(1).SlideShowTransition.AdvanceTime
4.25
など、小数の数値でOKみたいですね。
※一瞬、5秒とかなのでDate型で秒数かと思ったが、普通の数値でした。

2.Excelの切り替え秒数リストからセットする

Excel → PowerPoint

ここからが、腕の見せ所・・・なんだけど、
いつものように A列に入力された値をセットしてみます。

A1に切り替え秒数と見出しを入れといて、
あとは、タテにデータが無くなるまで、
既存パワポ(起動済みのアクティブプレゼン)にセットしてみます。

Option Explicit

Sub Excelで起動済みパワポの切り替え秒数をセット20220508()

    '起動済みのパワポを捕まえる
    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 "秒数セット用のパワポを開いてから、再テストしてね", vbExclamation
        Exit Sub
    End If
    
    'データをセットする
    Dim r As Range   'Excel 左上
    
    Set r = Range("A1")  'A1からテストで始める
    
    Dim p As Integer  'Excel側:行カウンタ pp:セットするページ
    
    p = 1
    While Len(Trim("" & r.Offset(p, 0))) <> 0  '秒数データがある間ループ
        'ppのセットページがなかったら足りなかったら、Excelのデータが多かったら
        If p > ppApp.ActivePresentation.Slides.Count Then
            'メッセージを出して、数が合わないことを知らせる
            MsgBox "パワポのページが足りません、確認してください", vbExclamation
            Exit Sub  '伝えるだけ伝えて、処理を終了
        End If
        
        'pページのスライド 遷移 SlideShowTransition
        With ppApp.ActivePresentation.Slides(p).SlideShowTransition
            .AdvanceOnClick = msoTrue  'クリック時。
            .AdvanceOnTime = msoTrue   '自動的に切替
            .AdvanceTime = r.Offset(p, 0).Value  '値をそのままセット、文字だったら・・ごめん
        End With
        
        p = p + 1  '次の位置へ
    Wend

    '↑逆に、Excle側のデータが足りない時ってあるの？何かのミスで？？
    If p <= ppApp.ActivePresentation.Slides.Count Then 'パワポの方がページ数多かったら？
        'メッセージを出して、数が合わないことを知らせる
        MsgBox "Excelの秒数データが足りません。ページ数とセット数を確認してください"
        Exit Sub  '伝えるだけ伝えて、処理を終了
    End If
    
    '無事終了、やったね
    MsgBox "セット終了"

End Sub