蛇足1.パワポのアクティブスライドからオブジェクトの名前をエクセルに落とす

Option Explicit

'起動済みの既存 パワーポイント スライド .Shapes から テキストを取り出す
'アクティブシートに名前とテキストをセット
Sub test20220915ppスライド内シェイプ名取得()

    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 r As Range  '基準、左上のセル。ここではB5
    Set r = Range("b5")

    Range(r, r.Offset(99, 2)).ClearContents   '99行データを決め打ちでクリア
    
    '見出しを書き込む r.Range("A1")よりr.Offset(1, 0)と書いた方がよかったかも？
    r.Range("A1") = "名前 Shape.Name"
    r.Range("B1") = "テキスト objShape.TextFrame.TextRange.Text"

    Dim p As Integer, y As Integer   'pページ、y行
    Dim objShape As Object           'As PowerPoint.Shape パワポのシェイプ、テキスト、図形ほか
        
    y = 1  '取得したテキストデータを二行目から書きたいので
    p = ppApp.ActiveWindow.Selection.SlideRange.SlideIndex '選択しているページ
    
    For Each objShape In ppApp.ActivePresentation.Slides(p).Shapes
        r.Offset(y, 0) = objShape.Name 'オブジェクトの名前 0列目
     
        'オブジェクトがテキストを持っているか？チェックしてからセット
        If objShape.HasTextFrame = msoTrue Then 'テキストフレームあり
            If objShape.TextFrame.HasText = msoTrue Then 'テキスト範囲あり
                r.Offset(y, 1) = objShape.TextFrame.TextRange.Text '1列目へテキスト
            End If
        End If
        
        y = y + 1   'セットする行を次へ
        
    Next
    
    MsgBox "処理終了"
    
End Sub

過去に作成した
www.youtube.com

Excel VBA で PowerPointのタイトルテキストを取得したい Shapes からテキストを取り出す
ken3memo.hatenablog.com
だと、すべて、取得してしまうので、
現在処理中のスライドのみ、データを落とすように変更する。

蛇足2.Excelでアクティブスライドのppオブジェクトに名前を付ける※名前の変更

蛇足2.パワポのアクティブスライドのシェイプ名.Nameに値をセットして変更する

'起動済みのパワーポイントスライド .Shapes の名前 .Name変更
'アクティブシートの名前を使用してセット

Sub test20220915ppスライド内シェイプ名変更()

    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 r As Range  '基準、左上のセル。ここではB5
    Set r = Range("b5")

    Dim p As Integer, y As Integer   'pページ、y行
    Dim objShape As Object           'As PowerPoint.Shape パワポのシェイプ、テキスト、図形ほか
        
    Dim 変更前Name As String
    Dim 変更後Name As String
    
    p = ppApp.ActiveWindow.Selection.SlideRange.SlideIndex 'pp変更ページ
    
    '見出しの次から処理する.Office(1,0)なのでOffice(y,0) y=1
    For y = 1 To 999  '最大999 そのまえにブレイク Exit Forさせるけど
        変更前Name = Trim("" & r.Offset(y, 0).Value) 'データセット
        変更後Name = Trim("" & r.Offset(y, 1).Value) 'データセット
        
        If Len(変更前Name) = 0 Then Exit For 'データ無しの時ループを抜ける
        
        '.Nameの変更
        Set objShape = Nothing
        On Error Resume Next  '取得エラー時に次へ※名前の禁則文字や重複？エラー
        Set objShape = ppApp.ActivePresentation.Slides(p).Shapes(変更前Name)
        '↑ここで、変更前の名前でアクセスできたか？ここで判断する
        On Error GoTo 0  'エラーを元に戻す※これを忘れると、デバッグ時にハマるから注意
        
        If objShape Is Nothing Then  'エラー判断、エラーの時
            r.Offset(y, 2).Value = "エラー発生、名前を確認してください"
        Else
            r.Offset(y, 2).Value = ""
            objShape.Name = 変更後Name  '.Nameに単純に代入する
        End If
        
    Next y

    MsgBox "処理終了"
    
End Sub