ExcelからPowerPointへ項目名が同じ名前のオブジェクトにデータをセットする

下記、知恵袋の質問に触発され
detail.chiebukuro.yahoo.co.jp
ExcelのデータをPowerPointに転記する
そんな処理をやってみます。

勝手に作った仕様は、
Excel:A1一行目～項目名 2行目からデータ
pp:図やテキストボックスに名前を付け、その場所にセットする

Excel1行目の項目名
PowerPoint同じ名前のオブジェクト
にデータをセットします

そんなラフなイメージです。

下記、いつものあのあのそのその解説とデバッグ動画です
youtu.be
https://youtu.be/-qPCSgPQuSw

#ExcelVBA #PowerPointVBA #マクロ #自動転記 #デバッグ

Excelからパワポにデータをセットしてみました。
Excelのソース ※パワポを開いた状態でテストしてみてください

Option Explicit

Sub Excelから起動済みのパワポにデータセット20220425()

    '起動済みのパワポを捕まえる
    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
    
    'データをセットする
    Dim r As Range   'Excel 左上
    
    Set r = Range("A1")  'A1からテストで始める
    
    Dim p As Integer  'Excel側:行カウンタ pp:セットするページ
    Dim x As Integer  'Excel 列カウンタ、
    Dim str転記列名 As String  'Excel:転記列名 pp:セットするオブジェクト名
    Dim ppObjShape As Object 'ppセットするオブジェクト
    
    p = 1
    While Len(Trim("" & r.Offset(p, 0))) <> 0  '左端にデータがある間ループ
        'ppのセットページがなかったら、1ページを最終にコピー
        If p > ppApp.ActivePresentation.Slides.Count Then
            'スライドを増やす
            ppApp.ActivePresentation.Slides(1).Copy  '1ページ目をコピー
            ppApp.ActivePresentation.Slides.Paste p  '最終スライドpageに貼り付け
        End If
        
        'pページのスライドにデータをセットする
        For x = 0 To 99  '99までループにして途中でExitするループ
            str転記列名 = Trim("" & r.Offset(0, x)) '0行目のx列、項目名を取得
            If Len(str転記列名) = 0 Then Exit For '転記項目が無くなったら抜ける
            
            'Excelから単純にItem(項目名)でデータセット、エラーを無視して項目名無しを回避
            On Error Resume Next  'エラーが発生しても強引に次の命令に行け
            Set ppObjShape = Nothing  'これが無いと、前回オブジェクトが残る
            Set ppObjShape = ppApp.ActivePresentation.Slides(p).Shapes(str転記列名) 'セットするオブジェクト
            ppObjShape.TextFrame.TextRange.Text = r.Offset(p, x).Text 'Excelから文字列を代入
            On Error GoTo 0  '忘れないで戻すぞ
        Next x
        p = p + 1  '次の位置へ
    Wend

    MsgBox "セット終了"

End Sub