PowerPointにExcelから テキスト変更とシェイプの名前変更をVBAで行う 不具合・バグ付きですが参考となれば

作成したコードをつなぎ合わせて、ツールぽい物を作ってみました。
手前味噌の結合テストです、よろしくお願いします。

https://youtu.be/-Tof_YBjjLo
目次
00:00 あいさつ 1.成果物を見せる
00:30 1.1 スクショもどきをシートへ落としシェイプの情報を付ける
02:09 1.2 テキストの修正
10:55 1.3 シェイプ名の修正
12:45 1.4 新規プレゼンで再度説明
16:37 コード説明 2.1 スクショもどきをシートへ落としシェイプの情報を付ける
18:53 コード説明 2.2 テキストの修正
20:00 Shape HasTextFrameのチェックはなぜ？必要か？線アローなどテキストを持てない図形をチェック
22:46 コード説明 2.3 シェイプ名の修正
24:41 3.おわりの挨拶

#PowerPointVBA #ExcelVBA #Shape #Text #マクロ #パワーポイント #エクセル

1.成果物を見せる

1.1 スクショもどきをシートへ落としシェイプの情報を付ける
00:30
https://www.youtube.com/watch?v=-Tof_YBjjLo&t=30

アクティブなパワポのスライドをjpgにして、
Excelのシートへ貼り付けました。
隣にシェイプの情報 ID,Name,座標,テキストを書き出し、
矢印を引いてみました。

関連項目は前回の
Excel 表のテーブル化 As ListObject テーブルのソート処理
https://www.youtube.com/watch?v=b0K6muJYdOI
↑を見て、笑ってください

1.2 テキストの修正

02:09 https://www.youtube.com/watch?v=-Tof_YBjjLo&t=129

書き出されたシェイプ情報Page,IDを利用して、
Excelに入力されたテキストをPowerPointへセット、更新処理を行う

良い感じ(自分で言うなよ)ですが、改行処理がイマイチなので、工夫が必要です

コード説明と関連項目は
ExcelからパワポへSUM計算結果とテキストを指定位置に代入・転記する PowerPointのスライドを開き 指定ページに値と文字列をセットする マクロ VBA
https://www.youtube.com/live/VUw8a-xW55w?t=56
↑を見て、笑ってください

1.3 シェイプ名の修正

10:55 https://www.youtube.com/watch?v=-Tof_YBjjLo&t=655

シェイプの名前は、
配置 オブジェクトの選択と表示 から 簡単に修正可能ですが、
順番が 前面・背面の重ねの表示順なので
Excelで座標(Top,Left)でソートして、位置をわかりやすく。

コード説明と関連項目は
マクロ PowerPointからExcelへシェイプの一覧を落とし名前を手動修正後にExcelからPowerPointへ戻したい 蛇足で画像位置とサイズを取得して一括変更処理を実演・・
https://www.youtube.com/watch?v=o0PVL1v27Ts&t=159s
↑を見て、笑ってください

1.4 新規プレゼンで再度説明
12:45 https://www.youtube.com/watch?v=-Tof_YBjjLo&t=765
新規のプレゼンを開いて
スライドの追加
テキストや図形を追加する

シェイプ名を変えたり、テキストを変更したり。

2.今回の修正点を軽く説明する

2.1 スクショもどきをシートへ落としシェイプの情報を付ける
16:37
https://www.youtube.com/watch?v=-Tof_YBjjLo&t=997

マクロのボタンを押したかったので、
"ひな型"シートをコピーする方式に変更しました。

先に"スライドXXX"のシートを全て削除してから、
    'ひな型シートを利用する
    Dim wb As Workbook
    Set wb = ThisWorkbook  '処理対象は現在のマクロ付きブックにする
    Dim sh As Worksheet
    Dim n As Integer
    '24/03/22:シート"スライドXX"を名前で判断してまず削除する
    'シートを後ろから探し、条件に合致するシートを削除
    For n = wb.Sheets.Count To 1 Step -1
        Set sh = wb.Sheets(n)  'n番目のシート
        If Left(sh.Name, 4) = "スライド" Then  '名前がスライド*を削除する
            Application.DisplayAlerts = False  '親切な確認メッセを無効にする
            sh.Delete
            Application.DisplayAlerts = True   'ONに戻す、エチケット？
        End If
    Next n

"ひな型"シートをコピーする
        '画像をシートへ貼る シートは"ひな型"をコピーする
        wb.Sheets("ひな型").Copy After:=wb.Worksheets(wb.Worksheets.Count)
        DoEvents
        Set shNEW = wb.Worksheets(wb.Worksheets.Count) '一番後ろにコピーされたので
        shNEW.Name = "スライド" & p   '削除時も判断に使用:シート名をスライド1,2,3..にする
        'shNEW.Columns("A:A").ColumnWidth = 79.5  '列幅を変更する ひな型を利用するのでコメントにした

2.2 テキストの修正

18:53 コード説明 2.2 テキストの修正
https://www.youtube.com/watch?v=-Tof_YBjjLo&t=1133
20:00 Shape HasTextFrameのチェックはなぜ？必要か？線アローなどテキストを持てない図形をチェック

書き出されたシェイプ情報Page,IDを利用して、
Excelに入力されたテキストをPowerPointへセット、更新処理を行う

単純に、戻しただけです。

                'オブジェクトがテキストを持っているか？チェックしてからセット
                If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                    objShape.TextFrame.TextRange.Text = rBASE.Offset(y, 8).Text
                    '.Textテキストを書き込む↑※03/22改行判断を後日・・忘れるなよ・・・
                End If

改善点:実行結果の説明でやりましたが、
更新後に、"スクショもどき" が そのままなので、
これが、更新されると良いと思ったり。

2.3 シェイプ名の修正

22:46 コード説明 2.3 シェイプ名の修正
https://www.youtube.com/watch?v=-Tof_YBjjLo&t=1366
書き出されたシェイプ情報Page,IDを利用して、
戻しました。

            '名前を変更する 2列 0,1,2で2
            objShape.Name = rBASE.Offset(y, 2) '名前をセット

3.おわりの挨拶

こんな感じで、ツールもどきを作ってみました。
あとは、
積み残した不具合
や
図形の一括移動
フォントや色の変更
など、VBAのプロパティを探るついでに、肉付けできたらなぁ・・と思ってます。

何か、アイデア、改善点などあったら、
気軽にコメント欄へ書き込んでください。

作成手順やVBAコードが何かのヒントとなれば幸いです。

ではまたぁ。

ソースコード:

Option Explicit

Const str基準セル = "C4"  'データの出力先、表の起点
Const スクショもどき幅 = 480  'ExcelのA1に貼り付けた後に幅を調整する↓も忘れずに。
Const スケール調整 = (480 / 960)  'スクショもどきと現物を調整する

'起動済みの既存 パワーポイントのスライドから
'パワポのシェイプ情報とイメージjpgをexcelシートへ書き出す
'ex:新規ブックを追加して、pp:スライドの情報をex:シート単位で貼り付ける
'24/03/19:テーブル化とTop,Leftの2項目でソート
'24/03/22:シート"スライドXX"を名前で判断して削除する
'24/03/22:シート"ひな型"を最後にコピーして、データをセットする
Sub test240322_01ppスライドのシェイプ情報をシートへひな型使用()

    Dim ppApp As Object 'As PowerPoint.Application
    
    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 wb As Workbook
    Set wb = ThisWorkbook  '処理対象は現在のマクロ付きブックにする
    Dim sh As Worksheet
    Dim n As Integer
    '24/03/22:シート"スライドXX"を名前で判断してまず削除する
    'シートを後ろから探し、条件に合致するシートを削除
    For n = wb.Sheets.Count To 1 Step -1
        Set sh = wb.Sheets(n)  'n番目のシート
        If Left(sh.Name, 4) = "スライド" Then  '名前がスライド*を削除する
            Application.DisplayAlerts = False  '親切な確認メッセを無効にする
            sh.Delete
            Application.DisplayAlerts = True   'ONに戻す、エチケット？
        End If
    Next n

    Dim shNEW As Worksheet '新規のシート用に変数を作成する
    
    Dim strJPGNAME As String  '一時保存する名前
    strJPGNAME = ThisWorkbook.Path & "\ppスライドtemp.jpg"

    'Application.Top = 200  '動画作成用、新規のブック位置,本番では消す
    'Application.Left = 200 '動画作成用、新規のブック位置,本番では消す

    Dim picShape As Shape  '挿入画像はShapeなので

    Dim p As Integer, y As Integer   'pページ、y行
    Dim objShape As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか
    
    '24/03/22:シート"ひな型"を最後にコピーして、データをセットする
    'パワポのスライドをExcelシートに
    For p = 1 To ppApp.ActivePresentation.Slides.Count  'スライド数ループ pページ
      'pp画像を用意する 単純に.Exportでテンポラリ画像を作成
        ppApp.ActivePresentation.Slides(p).Export strJPGNAME, "JPG"
        DoEvents  '↑jpgファイルを作成しているので、念のため
        
        '画像をシートへ貼る シートは"ひな型"をコピーする
        wb.Sheets("ひな型").Copy After:=wb.Worksheets(wb.Worksheets.Count)
        DoEvents
        Set shNEW = wb.Worksheets(wb.Worksheets.Count) '一番後ろにコピーされたので
        shNEW.Name = "スライド" & p   '削除時も判断に使用:シート名をスライド1,2,3..にする
        'shNEW.Columns("A:A").ColumnWidth = 79.5  '列幅を変更する ひな型を利用するのでコメントにした
        
        ' 画像を0,0へ 埋め込み形式で挿入 ファイル名,リンク,保存保持,left,top,Width,Height
        Set picShape = shNEW.Shapes.AddPicture(strJPGNAME, False, True, 0, 0, -1, -1)
        
        picShape.Name = "ppスライド" & p
        picShape.Width = スクショもどき幅   '挿入後、幅を調整する

      'ここから、シェイプの情報を書きこむ
        '書き込み開始位置の左上のセルを指定して、offictで対応する
        Dim rBASE As Range   '拠点、書き込みの左上を代入する
        Set rBASE = shNEW.Range(str基準セル)

        rBASE.Select
        '0行目に見出しを書き込む
        rBASE.Offset(0, 0) = "Page番号"
        rBASE.Offset(0, 1) = "ID"
        rBASE.Offset(0, 2) = "Name"
        rBASE.Offset(0, 3) = "Type"     '種類※あると便利
        rBASE.Offset(0, 4) = "Left"     'ソートで仕様
        rBASE.Offset(0, 5) = "Top"
        rBASE.Offset(0, 6) = "Width"    '幅と高さ 24/03/02
        rBASE.Offset(0, 7) = "Height"
        rBASE.Offset(0, 8) = "テキスト"  'テキストがあれば判断時便利かな？
        
        'pページのスライド内のシェイプを探る
        y = 1 '基準の一つ下からセットする
        For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes
            rBASE.Offset(y, 0) = p   'スライド番号(ページ番号)
            rBASE.Offset(y, 1) = objShape.ID    'IDで今回、区別したいので※24/03/02追加
            rBASE.Offset(y, 2) = objShape.Name  'オブジェクトの名前
            rBASE.Offset(y, 3) = objShape.Type  '※種類
         
            rBASE.Offset(y, 4) = objShape.Left  '位置 左上の左 判断材料
            rBASE.Offset(y, 5) = objShape.Top   '位置 左上の縦
         
            rBASE.Offset(y, 6) = objShape.Width '
            rBASE.Offset(y, 7) = objShape.Height
            
            'オブジェクトがテキストを持っているか？チェックしてからセット
            If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                    rBASE.Offset(y, 8) = objShape.TextFrame.TextRange.Text
                    'テキストを書き込む↑※03/22改行判断を後日・・忘れるなよ・・・
                End If
            End If
            
            y = y + 1   'セットする行を次へ
            
        Next
        
        '↑で出力したデータをテーブル化 CurrentRegionで範囲指定してテーブル作成
        Dim objTB As ListObject  'テーブルはリストオブジェクト
        Set objTB = shNEW.ListObjects.Add(xlSrcRange, rBASE.CurrentRegion, , xlYes)
        
        Dim strTBName As String
        strTBName = "TB" & shNEW.Name  'TB+シート名をテーブル名する
        objTB.Name = strTBName
        DoEvents

        'Top,Leftでソートする
        objTB.Sort.SortFields.Clear  'ソートの項目をクリアしてから追加する
        
        objTB.Sort.SortFields.Add2 _
            Key:=Range(strTBName & "[Top]"), SortOn:=xlSortOnValues, Order:=xlAscending _
            , DataOption:=xlSortNormal
        objTB.Sort.SortFields.Add2 _
            Key:=Range(strTBName & "[Left]"), SortOn:=xlSortOnValues, Order:=xlAscending _
            , DataOption:=xlSortNormal

        With objTB.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    Next
    
    MsgBox "処理終了、画像を確認してください"

End Sub


'Excel矢印を作成して、場所を指す
'セルの位置から矢印を画像に引く
'24/03/19:Set rBASE = Range("B1")をSet rBASE = Range(str基準セル)にしただけ
'24/03/22:Const スケール調整 = (480 / 960)を頭に移動させただけ
Sub test240322_02スクショもどきに矢印を引く()

    Dim shpArrow As Shape  '矢印にする
    
    Dim rBASE As Range
    Set rBASE = Range(str基準セル)  '一番上でConst定義した出力先を使う
    
    Dim y As Integer
    
    Dim Start_X As Double, Start_Y As Double
    Dim End_X As Double, End_Y As Double
    
    For y = 1 To 999  'いつものとりあえず999まで回す
        If Trim("" & rBASE.Offset(y, 0)) = "" Then Exit For 'データ無しなら抜ける
    
        Start_X = rBASE.Offset(y, 4) * スケール調整 'ppのLeft
        Start_Y = rBASE.Offset(y, 5) * スケール調整 'ppのTop
        
        End_X = rBASE.Offset(y, 2).Left  '3列目セルのLeft 0から始まるので2を指定
        End_Y = rBASE.Offset(y, 2).Top + (rBASE.Offset(y, 2).Height / 2) 'セルのTop + Height÷2
    
        '矢印の作成
        Set shpArrow = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Start_X, Start_Y, End_X, End_Y)
        shpArrow.Name = "矢印" & y  '名前を変更、後で消しやすいように
        With shpArrow.Line  '線のパラメーターをセットする、形を変える
            .BeginArrowheadStyle = msoArrowheadTriangle '開始の形
            .EndArrowheadStyle = msoArrowheadTriangle   '終了の形
            .Visible = msoTrue
            .Weight = 4.5  '幅
        End With

    Next
    
End Sub

'シェイプの削除
'24/03/22:ActiveSheetのIf Left(Shp.Name, 2) = "矢印"を判断なので、関数名だけ変えた
Sub test240322_03shp_Delete()  '削除  矢印XXX のシェイプを削除する

    Dim Shp As Shape
    Dim n As Integer
    
    'ループで後ろから"矢印"の名前が付くシェイプを消す
    For n = ActiveSheet.Shapes.Count To 1 Step -1
        Set Shp = ActiveSheet.Shapes(n)
        If Left(Shp.Name, 2) = "矢印" Then  '頭2文字が"矢印"なら削除する
            Shp.Delete
        End If
    Next
    
End Sub

'Excelシートの表で修正した テキストの値を起動済みのパワーポイントへセットする
'基準のテーブル 0列:Page, 1列:Idを使用して、シェイプを探し、
'TextRangeに値をセットする
'不具合:改行コード関係を調べる、大きな枠、長文や箇条書きなどには向かない？
Sub test240322_04ppシェイプのテキスト内容を書き換える()

    Dim ppApp As Object 'As PowerPoint.Application
    
    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 p As Integer, y As Integer   'pページ、y行
    Dim ShpWORK As Object   'As PowerPoint.Shape ループでIDを探すときに使う
    Dim objShape As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか

    Dim rBASE As Range
    Set rBASE = Range(str基準セル)  '一番上でConst定義した出力先を使う

    '1行目からIDがなくなるまでループする
    For y = 1 To 9999  '9999までと言いつつ↓で終了チェック、おいおい・・・
        If Trim("" & rBASE.Offset(y, 2)) = "" Then Exit For  'ID列に値が無かったら、ループを抜ける
        
        If Trim("" & rBASE.Offset(y, 8)) <> "" Then  '8列目,名前列に変更用の名前がある時だけセットする
            Set objShape = Nothing  'セット先のシェイプを初期化
            
            'pページのスライド内のシェイプをIDで探して値をセットする
            p = rBASE.Offset(y, 0)  'スライド番号(ページ番号)
            For Each ShpWORK In ppApp.ActivePresentation.Slides(p).Shapes 'ページ内の全てをあさる
                'IDが一致するか、チェックする
                If ShpWORK.ID = rBASE.Offset(y, 1) Then  'IDと比較
                    Set objShape = ShpWORK  '見つけたので、オブジェクトをセットする
                    Exit For   '探すループを抜ける
                End If
            Next   'IDを探す↑ループ
    
            'ID有無の判断
            If objShape Is Nothing Then  '見つからないとき
                MsgBox p & "ページのID=" & rBASE.Offset(y, 1) & "が見つかりません"
                'Exit Sub '保留
            Else
                'テキストを変更する 8列
                'オブジェクトがテキストを持っているか？チェックしてからセット
                If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
                    objShape.TextFrame.TextRange.Text = rBASE.Offset(y, 8).Text
                    '.Textテキストを書き込む↑※03/22改行判断を後日・・忘れるなよ・・・
                End If
            End If
        
        End If  'テキスト列にテキストがある時だけ↑処理

    Next y   '行の↑ループ

    ppApp.ActivePresentation.Slides(p).Select '更新スライドページを選択

    MsgBox "処理終了、セットされたテキストを確認してください"
    '↑改善点:テキストが更新されるなら、
    '"スクショもどき"も更新されると、操作的にはわかりやすくていいかも？

End Sub


'Excelシートの表で修正した 名前を起動済みのパワーポイントへセットする
'基準のテーブル 0列:Page, 1列:Idを使用して、シェイプを探し、
'.Nameに名前をセットする
Sub test240322_05ppシェイプの名前を書き換える()

    Dim ppApp As Object 'As PowerPoint.Application
    
    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 p As Integer, y As Integer   'pページ、y行
    Dim ShpWORK As Object   'As PowerPoint.Shape ループでIDを探すときに使う
    Dim objShape As Object  'As PowerPoint.Shape 'パワポのシェイプ、テキスト、図形ほか

    Dim rBASE As Range
    Set rBASE = Range(str基準セル)  '一番上でConst定義した出力先を使う

    '1行目からIDがなくなるまでループする
    For y = 1 To 9999  '9999までと言いつつ↓で終了チェック、おいおい・・・
        If Trim("" & rBASE.Offset(y, 2)) = "" Then Exit For  'ID列に値が無かったら、ループを抜ける
        
        Set objShape = Nothing  'セット先のシェイプを初期化
        
        'pページのスライド内のシェイプをIDで探して値をセットする
        p = rBASE.Offset(y, 0)  'スライド番号(ページ番号)
        For Each ShpWORK In ppApp.ActivePresentation.Slides(p).Shapes 'ページ内の全てをあさる
            'IDが一致するか、チェックする
            If ShpWORK.ID = rBASE.Offset(y, 1) Then  'IDと比較
                Set objShape = ShpWORK  '見つけたので、オブジェクトをセットする
                Exit For   '探すループを抜ける
            End If
        Next   'IDを探す↑ループ

        'ID有無の判断
        If objShape Is Nothing Then  '見つからないとき
            MsgBox p & "ページのID=" & rBASE.Offset(y, 1) & "が見つかりません"
            'Exit Sub '保留
        Else
            '名前を変更する 2列 0,1,2で2
            objShape.Name = rBASE.Offset(y, 2) '名前をセット
        End If
        
    Next y   '行の↑ループ

    ppApp.ActivePresentation.Slides(p).Select '更新スライドページを選択

    MsgBox "処理終了、更新されたシェイプの名前を確認してください"

End Sub

---

イラスト PC キーボードを触っている太ったプログラマー 画面に表示されたコードを見て悩んでます