シェイプのプロパティ変更

'----------------------------------------------
' メイン処理：ファイルダイアログでExcelファイルを選択し、
' 未オープンなら開いて、すべてのシェイプの配置設定を変更する
'----------------------------------------------
Sub SetShapesFreeFloatingWithFileDialog()
    Dim fdOpen As FileDialog
    Dim strFilePath As String
    Dim wbSelected As Workbook

    Set fdOpen = Application.FileDialog(msoFileDialogFilePicker)
    With fdOpen
        .Title = "対象のExcelファイルを選択してください"
        .Filters.Clear
        .Filters.Add "Excelファイル", "*.xls;*.xlsx;*.xlsm;*.xlsb"
        .AllowMultiSelect = False
        If .Show = -1 Then
            strFilePath = .SelectedItems(1)
        Else
            MsgBox "ファイルが選択されませんでした。処理を中止します。", vbInformation
            Exit Sub
        End If
    End With

    If IsWorkbookOpen(strFilePath) Then
        MsgBox "選択したブックはすでに開かれています。" & vbCrLf & _
               "すべての処理を中止します。", vbCritical
        Exit Sub
    End If

    Set wbSelected = Workbooks.Open(strFilePath)
    SetAllShapesFreeFloatingInWorkbook wbSelected

    MsgBox "すべてのシェイプの設定が完了しました。" & vbCrLf & _
           "ファイルを保存して閉じてください。", vbInformation
End Sub

'----------------------------------------------
' 関数：指定ファイルパスのブックがすでに開かれているか判定
'----------------------------------------------
Function IsWorkbookOpen(ByVal strFullPath As String) As Boolean
    Dim wb As Workbook
    IsWorkbookOpen = False
    For Each wb In Application.Workbooks
        If StrComp(wb.FullName, strFullPath, vbTextCompare) = 0 Then
            IsWorkbookOpen = True
            Exit For
        End If
    Next wb
End Function

'----------------------------------------------
' サブルーチン：指定したブック内の全シート・全シェイプを処理
'----------------------------------------------
Sub SetAllShapesFreeFloatingInWorkbook(ByVal wbTarget As Workbook)
    Dim wsCurrent As Worksheet
    Dim lngWsIdx As Long
    For lngWsIdx = 1 To wbTarget.Worksheets.Count
        Set wsCurrent = wbTarget.Worksheets(lngWsIdx)
        SetShapesPlacementRecursive wsCurrent.Shapes
    Next lngWsIdx
End Sub

'----------------------------------------------
' サブルーチン：ShapesまたはGroupShapesコレクション内の
' すべてのシェイプ・グループ内も再帰的に処理
'----------------------------------------------
Sub SetShapesPlacementRecursive(ByVal objShapes As Object)
    Dim shpItem As Shape
    Dim lngIdx As Long

    For lngIdx = 1 To objShapes.Count
        Set shpItem = objShapes(lngIdx)
        ' セルに合わせて移動やサイズ変更をしない設定
        shpItem.Placement = xlFreeFloating

        ' グループ化シェイプの場合はグループ内も再帰的に処理
        If shpItem.Type = msoGroup Then
            SetShapesPlacementRecursive shpItem.GroupItems
        End If
    Next lngIdx
End Sub