'Excel VBAで､特定のシート内にあるすべての図形の名称を取得し､
'同名の図形があった場合にはグループ化された図形も含めてユニークな名前にリネームしたいです｡
'グループ図形を解除せずにグループ内の個々の図形の名前も取得・変更できるようにしたいです。
' また、同じ名前があったかどうかを確認するために Dictionary を使いたいのですが、
'再帰的な処理を行う場合､Dictionary を引数として渡すのと､パブリック変数として保持するのとでは
'どちらが望ましいかも理由付きで教えてください｡ 最後に､図形名の変更処理を実装した､
'具体的で再利用可能なサンプルコードを提示してください｡図形名の変更履歴は不要です｡
'GPT

Sub Rename()
    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim usedNames As Object
    Set usedNames = CreateObject("Scripting.Dictionary")

    Dim shp As Shape
    For Each shp In ws.Shapes
        
        MsgBox shp.Name
    Next shp
End Sub

Sub RenameAllShapesOnSheet()
    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim usedNames As Object
    Set usedNames = CreateObject("Scripting.Dictionary")

    Dim shp As Shape
    For Each shp In ws.Shapes
        Call RenameShapeRecursive(shp, usedNames)
    Next shp
End Sub

Sub RenameShapeRecursive(shp As Shape, usedNames As Object)
    Dim originalName As String
    Dim newName As String
    Dim prefix As String
    Dim numPart As Long

    originalName = shp.Name
    newName = originalName

    ' プレフィックスと数字に分解
    ParseNameParts originalName, prefix, numPart

    ' 名前がすでに使われていればインクリメントしてユニーク名生成
    Do While usedNames.exists(newName)
        numPart = numPart + 1
        newName = prefix & " " & numPart
    Loop

    ' 名前を変更し、使用済みに記録
    If newName <> originalName Then shp.Name = newName
    usedNames(newName) = True

    ' グループ内の図形も再帰的に処理
    If shp.Type = msoGroup Then
        Dim gShp As Shape
        For Each gShp In shp.GroupItems
            Call RenameShapeRecursive(gShp, usedNames)
        Next gShp
    End If
End Sub

Sub ParseNameParts(ByVal shapeName As String, ByRef prefix As String, ByRef number As Long)
    Dim i As Long
    Dim ch As String
    Dim nameLen As Long
    nameLen = Len(shapeName)

    ' 後ろから見て数字がどこまで続いているか判定
    For i = nameLen To 1 Step -1
        ch = Mid(shapeName, i, 1)
        If Not IsNumeric(ch) Then Exit For
    Next i

    If i < nameLen Then
        prefix = Trim(Left(shapeName, i))
        number = CLng(Mid(shapeName, i + 1))
    Else
        prefix = shapeName
        number = 1
    End If
End Sub

'ではそのシートに名前が重複する新たな図形を追加しようとしたときに、追加する図形の名前は変えずに、
'シート上に既にある図形名を変更するには？名前の変更手順は上記と同じです。
'またこの処理を開始するときにはシート上に重複する図形名はないものとします。
'-----------------------------------------------------------------------------
Sub AddShapeWithFixedName()
    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim fixedName As String
    fixedName = "テキスト ボックス 1"

    Dim usedNames As Object
    Set usedNames = CreateObject("Scripting.Dictionary")
    
    ' すでにある図形の名前をすべて Dictionary に登録
    Dim shp As Shape
    For Each shp In ws.Shapes
        usedNames(shp.Name) = True
    Next shp

    ' 追加予定の名前がすでに使われていれば、既存図形を改名する
    If usedNames.exists(fixedName) Then
        Set shp = ws.Shapes(fixedName)
        Call RenameShapeRecursive(shp, usedNames)
    End If

    ' 新しい図形を追加（名前は固定）
    Dim newShp As Shape
    Set newShp = ws.Shapes.AddTextbox( _
        Orientation:=msoTextOrientationHorizontal, _
        Left:=100, Top:=100, Width:=200, Height:=50)

    newShp.Name = fixedName
    newShp.TextFrame.Characters.Text = "追加された " & fixedName
End Sub


claude------------------------------------------------------------------------


' メイン処理：指定シートの全図形の名前をユニークにする
Public Sub RenameAllShapesToUnique(ws As Worksheet)
    Dim nameDict As Object
    Dim shp As Shape
    
    ' Dictionary作成
    Set nameDict = CreateObject("Scripting.Dictionary")
    
    ' 全図形を処理
    For Each shp In ws.Shapes
        Call ProcessShape(shp, nameDict)
    Next shp
    
    Debug.Print "図形名の重複チェックとリネーム処理が完了しました。"
End Sub

' 図形処理の再帰関数（引数でDictionaryを渡す）
Private Sub ProcessShape(shp As Shape, ByRef nameDict As Object)
    Dim originalName As String
    Dim newName As String
    Dim i As Long
    
    originalName = shp.Name
    
    ' グループ図形の場合は個々の図形も処理
    If shp.Type = msoGroup Then
        Debug.Print "グループ図形を検出: " & originalName
        
        ' グループ内の個々の図形を再帰処理
        For i = 1 To shp.GroupItems.Count
            Call ProcessShape(shp.GroupItems(i), nameDict)
        Next i
    End If
    
    ' 名前の重複チェックとリネーム
    newName = GenerateUniqueName(originalName, nameDict)
    
    If originalName <> newName Then
        shp.Name = newName
        Debug.Print "リネーム: " & originalName & " → " & newName
    Else
        Debug.Print "名前確認: " & originalName
    End If
    
    ' Dictionaryに追加
    nameDict(newName) = True
End Sub

' ユニークな名前を生成する関数
Private Function GenerateUniqueName(baseName As String, ByRef nameDict As Object) As String
    Dim counter As Long
    Dim candidateName As String
    
    candidateName = baseName
    counter = 1
    
    ' 重複がなくなるまでループ
    Do While nameDict.Exists(candidateName)
        candidateName = baseName & "_" & counter
        counter = counter + 1
    Loop
    
    GenerateUniqueName = candidateName
End Function

' 使用例1：アクティブシートの図形を処理
Public Sub Example_ProcessActiveSheet()
    Call RenameAllShapesToUnique(ActiveSheet)
End Sub

' 使用例2：特定シートの図形を処理
Public Sub Example_ProcessSpecificSheet()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1") ' シート名を指定
    Call RenameAllShapesToUnique(ws)
End Sub

' 使用例3：全シートの図形をまとめて処理
Public Sub Example_ProcessAllSheets()
    Dim ws As Worksheet
    
    For Each ws In ThisWorkbook.Worksheets
        Debug.Print "処理中のシート: " & ws.Name
        Call RenameAllShapesToUnique(ws)
    Next ws
End Sub

' デバッグ用：シート内の全図形名を表示
Public Sub ShowAllShapeNames(ws As Worksheet)
    Dim shp As Shape
    
    Debug.Print "=== シート「" & ws.Name & "」の図形一覧 ==="
    
    For Each shp In ws.Shapes
        Call DisplayShapeInfo(shp, 0)
    Next shp
End Sub

' 図形情報表示の再帰関数（デバッグ用）
Private Sub DisplayShapeInfo(shp As Shape, indentLevel As Long)
    Dim indent As String
    Dim i As Long
    
    ' インデント文字列作成
    indent = String(indentLevel * 2, " ")
    
    Debug.Print indent & "図形名: " & shp.Name & " (タイプ: " & GetShapeTypeName(shp.Type) & ")"
    
    ' グループ図形の場合は個々の図形も表示
    If shp.Type = msoGroup Then
        For i = 1 To shp.GroupItems.Count
            Call DisplayShapeInfo(shp.GroupItems(i), indentLevel + 1)
        Next i
    End If
End Sub

' 図形タイプ名を取得する補助関数
Private Function GetShapeTypeName(shapeType As Long) As String
    Select Case shapeType
        Case msoAutoShape: GetShapeTypeName = "オートシェイプ"
        Case msoGroup: GetShapeTypeName = "グループ"
        Case msoPicture: GetShapeTypeName = "画像"
        Case msoTextBox: GetShapeTypeName = "テキストボックス"
        Case msoChart: GetShapeTypeName = "グラフ"
        Case msoTable: GetShapeTypeName = "表"
        Case Else: GetShapeTypeName = "その他(" & shapeType & ")"
    End Select
End Function