指定したブック上の全シェイプ内のテキストの一覧と、スペースまでの（スペースを含む）文字を削除

Sub シェイプのテキスト一覧A()
Dim ws As Worksheet
Dim outputWs As Worksheet
Dim targetShape As shape
Dim row As Long
Dim workbookPath As String
Dim targetWb As Workbook

' ブックのフルパスを取得
workbookPath = InputBox("操作対象になるブックのフルパスを入力してください", "ブックの選択")

' ブックを開く
Set targetWb = Workbooks.Open(workbookPath)

' 既存のシェイプの一覧シートを削除
Application.DisplayAlerts = False
On Error Resume Next
Set outputWs = targetWb.sheets("シェイプの一覧")
If Not outputWs Is Nothing Then
    outputWs.Delete
End If
On Error GoTo 0
Application.DisplayAlerts = True

' 結果を出力する新しいシートを作成
Set outputWs = targetWb.sheets.Add
outputWs.Name = "シェイプの一覧"

' 見出しを設定
outputWs.Cells(1, 1).Value = "シート名"
outputWs.Cells(1, 2).Value = "グループ名"
outputWs.Cells(1, 3).Value = "オブジェクト名"
outputWs.Cells(1, 4).Value = "テキスト"

' 見出しの書式設定
With outputWs.Range("A1:D1")
    .Interior.Color = RGB(255, 255, 0) ' 背景を黄色に設定
    .HorizontalAlignment = xlCenter ' センタリング
    .Font.Bold = False
End With

' 1行目を固定
outputWs.rows("2:2").Select
ActiveWindow.FreezePanes = True

row = 2

' 各ワークシートをループ
For Each ws In targetWb.Worksheets
    ' 各シェイプをループ
    For Each targetShape In ws.Shapes
        Call シェイプのテキスト一覧A_1(targetShape, outputWs, row, "", ws.Name)
    Next targetShape
Next ws

' セル幅を最適化
outputWs.columns("A:D").AutoFit

End Sub

Sub シェイプのテキスト一覧A_1(targetShape As shape, outputWs As Worksheet, ByRef row As Long, groupName As String, sheetName As String)
Dim i As Long
Dim shapeName As String

shapeName = targetShape.Name

' グループ化されたシェイプの場合
If targetShape.Type = msoGroup Then
    For i = 1 To targetShape.GroupItems.Count
        Call シェイプのテキスト一覧A_1(targetShape.GroupItems(i), outputWs, row, shapeName, sheetName)
    Next i
Else
    ' テキストがある場合
    If targetShape.TextFrame2.HasText Then
        outputWs.Cells(row, 1).Value = sheetName
        outputWs.Cells(row, 2).Value = groupName
        outputWs.Cells(row, 3).Value = shapeName
        outputWs.Cells(row, 4).Value = targetShape.TextFrame2.textRange.Text
        row = row + 1
    End If
End If

End Sub

Sub シェイプ内のスペースまでを削除()
Dim ws As Worksheet
Dim targetShape As shape
Dim workbookPath As String
Dim targetWb As Workbook

' ブックのフルパスを取得
workbookPath = InputBox("操作対象になるブックのフルパスを入力してください", "ブックの選択")

' ブックを開く
Set targetWb = Workbooks.Open(workbookPath)

' 各ワークシートをループ
For Each ws In targetWb.Worksheets
    ' 各シェイプをループ
    For Each targetShape In ws.Shapes
        Call 削除プロセス(targetShape)
    Next targetShape
Next ws

End Sub

Sub 削除プロセス(targetShape As shape)
Dim i As Long
Dim shapeText As String
Dim spacePosition As Long

' グループ化されたシェイプの場合
If targetShape.Type = msoGroup Then
    For i = 1 To targetShape.GroupItems.Count
        Call 削除プロセス(targetShape.GroupItems(i))
    Next i
Else
    ' テキストがある場合
    If targetShape.TextFrame2.HasText Then
        shapeText = targetShape.TextFrame2.textRange.Text

        ' 半角スペースと全角スペースをすべて削除
        Do
            spacePosition = InStr(shapeText, " ")
            If spacePosition > 0 Then
                shapeText = Mid(shapeText, spacePosition + 1)
            End If
        Loop While spacePosition > 0

        Do
            spacePosition = InStr(shapeText, "　")
            If spacePosition > 0 Then
                shapeText = Mid(shapeText, spacePosition + 1)
            End If
        Loop While spacePosition > 0

        targetShape.TextFrame2.textRange.Text = shapeText
    End If
End If

End Sub