【ExcelVBA】図形(Shape)を指定セル範囲の中央へ移動する

図形(Shape)を指定セル範囲の中央へ移動する方法を解説します。

一発で行う方法がありませんので、移動位置を計算して実行します。

ソースコード
解説
汎用関数化

ソースコード

Sub 図形を指定セル範囲の中央へ移動する()
    
    Dim 対象図形 As Shape
    Set 対象図形 = Worksheets("Sheet1").Shapes("TextBox 1")
    
    Dim 移動先セル範囲 As Range
    Set 移動先セル範囲 = Worksheets("Sheet1").Range("B2:D8")
    
    ' 余白を取得
    Dim 高さ余白 As Double
    高さ余白 = 移動先セル範囲.Height - 対象図形.Height
    Dim 幅余白 As Double
    幅余白 = 移動先セル範囲.Width - 対象図形.Width
    
    ' 上下、左右に余白が均等になるよう移動
    対象図形.Top = WorksheetFunction.Max(0, 移動先セル範囲.Top + 高さ余白 / 2)
    対象図形.Left = WorksheetFunction.Max(0, 移動先セル範囲.Left + 幅余白 / 2)
    
End Sub

解説

図形をセル範囲の中央へ移動するには、
移動先のTop(上位置)、Left(左位置)を計算して設定します。

例えばセル範囲の幅が100、図形の幅が80の場合、
余っている余白20を左右に10ずつ均等に配置すればよいです。

よって「移動先セル範囲.Width - 対象図形.Width」で余白を計算し、
それを2で割った値をセル範囲の左端(Top)に足せば移動先が求まるということですね。

ちなみにこのコードは図形がセル範囲より大きい場合でも実行できます。

例えば図形の方がセル範囲より大きい幅の場合、幅余白がマイナスになりますが、
これは「マイナス数値分だけ幅がはみ出している」ということを意味します。

その値の半分を左右に均等にはみ出すことでセンタリングができるため、
まったく同じコードでセンタリングが実行できています。

ただし、移動先がA列や1行目付近の場合、
中央配置の計算結果がマイナスになることがあります。

そのままだとエラーになってしまうため、
WorksheetFunction.Maxで最低でも0になるよう補正しています。

なお、選択中の図形を対象にする場合は、
以下のようにSelection.ShapeRange(1)からShapeを取得できます。

Dim 対象図形 As Shape
Set 対象図形 = Selection.ShapeRange(1)

　
単に「Set 対象図形 = Selection」だけだと、
「型が一致しません」エラーになるためご注意ください。

汎用関数化

今回の処理をよく行う方は汎用関数にして持っておくのがおすすめです。

' 図形をセル範囲の中央へ移動
Sub 図形をセル範囲の中央へ移動する(対象図形 As Shape, 移動先セル範囲 As Range)
    
    ' 余白を取得
    Dim 高さ余白 As Double
    高さ余白 = 移動先セル範囲.Height - 対象図形.Height
    Dim 幅余白 As Double
    幅余白 = 移動先セル範囲.Width - 対象図形.Width
    
    ' 上下、左右に余白が均等になるよう移動
    対象図形.Top = WorksheetFunction.Max(0, 移動先セル範囲.Top + 高さ余白 / 2)
    対象図形.Left = WorksheetFunction.Max(0, 移動先セル範囲.Left + 幅余白 / 2)
    
End Sub

' 使用例
Call 図形をセル範囲の中央へ移動する(Worksheets("Sheet1").Shapes("TextBox 1") _
                                              , Worksheets("Sheet1").Range("B2:D8"))