指定したフォルダパス内の全エクセルシート上のシェイプのテキストを出力

Sub シェイプのテキスト一覧A()
Dim ws As Worksheet
Dim outputWs As Worksheet
Dim targetShape As shape
Dim row As Long
Dim folderPath As String
Dim fileName As String
Dim targetWb As Workbook
Dim newWb As Workbook
Dim fso As Object
Dim outputFilePath As String

' フォルダのフルパスを取得
folderPath = InputBox("作業用フォルダのフルパスを入力してください", "フォルダの選択")
If folderPath = "" Then
    MsgBox "フォルダのパスが入力されていません。"
    Exit Sub
End If
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

outputFilePath = folderPath & "シェイプのテキスト一覧.xlsx"

' シェイプのテキスト一覧.XLSX ファイルを削除
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(outputFilePath) Then
    fso.DeleteFile outputFilePath
End If

' フォルダ内の全てのエクセルファイルを開く
fileName = Dir(folderPath & "*.xlsx")

' 新しいブックを作成
Set newWb = Workbooks.Add
' 結果を出力する新しいシートを作成
Set outputWs = newWb.sheets(1)
outputWs.Name = "シェイプのテキスト一覧"

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

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

row = 2

Do While fileName <> ""
    Set targetWb = Workbooks.Open(folderPath & fileName)

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

    targetWb.Close False
    fileName = Dir
Loop

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

' 新しいファイルに保存（既存ファイルがあれば上書き）
On Error GoTo SaveError
Application.DisplayAlerts = False
newWb.SaveAs fileName:=outputFilePath, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
On Error GoTo 0

MsgBox "ファイルは正常に保存されました。"
Exit Sub

SaveError:
MsgBox “ファイルを保存できませんでした。エラー: ” & Err.Description
Application.DisplayAlerts = True
End Sub

Sub シェイプのテキスト一覧A_1(targetShape As shape, outputWs As Worksheet, ByRef row As Long, groupName As String, sheetName As String, bookName 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, bookName)
    Next i
Else
    ' テキストがある場合
    If targetShape.TextFrame2.HasText Then
        outputWs.Cells(row, 1).Value = bookName
        outputWs.Cells(row, 2).Value = sheetName
        outputWs.Cells(row, 3).Value = groupName
        outputWs.Cells(row, 4).Value = shapeName
        outputWs.Cells(row, 5).Value = targetShape.TextFrame2.textRange.Text
        row = row + 1
    End If
End If

End Sub