【Excel VBA】図形をセルの中心へ移動する

図形（今回はオートシェイプ）の位置がセルの中心からずれてしまっている場合、見栄えが悪いので位置を修正する方法を紹介します。（あまりにもズレいている場合は今回の対象からは外します）

＜マクロ実行のイメージ＞

下図のようにオートシェイプがセルの中心からずれているので、セルの中心へ移動させたい。

オートシェイプ位置を修正するマクロの流れ

①：オートシェイプの左上端のAddressを取得する

②：オートシェイプの中心がどのセルにあるのか算出する（①のセルからのOffset量を判定する）

③：オートシェイプを移動し、セルの中心になるように位置を修正する

④：①～③の処理を全オートシェイプに対して繰り返し(For Each構文)行う

①：オートシェイプの左上端のAddressを取得する

オートシェイプの位置（左上端）のAddressを取得する場合は「Shape.TopLeftCell」を使用します。

「$A$1」などの文字情報が返ってきます。

もし、$マークを外したい場合は (RowAbsolute:=False, ColumnAbsolute:=False)を.Addressの後に付けてください。

②：オートシェイプの中心がどのセルにあるのか算出する

オートシェイプの位置修正（あくまでも修正）なので、今回は「オートシェイプの中心があるセル」がオートシェイプの存在しているべきセルとして取り扱います。

下図の矢印の先へ位置修正を行うイメージです。

オートシェイプの中心の位置は、RangeオブジェクトとShapeオブジェクトのプロパティから、オートシェイプをどのセルの中心に位置修正するかを算出します。

③：オートシェイプを移動し、セルの中心になるように位置を修正する

オートシェイプ位置をセルの中心へ移動する場合は、RangeオブジェクトとShapeオブジェクトを使用して下図のイメージのように算出します。

コードの紹介

Sub シェイプ位置修正()

Dim Shape As Shape
Dim Shape_Range_TopLeft As String
Dim Shape_Offset_Row As Long
Dim Shape_Offset_Column As Long
Dim Range_Move As Range
    
For Each Shape In ActiveSheet.Shapes

'オートシェイプの左上端があるセルのアドレスを取得する
Shape_Range_TopLeft = Shape.TopLeftCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
 
'オートシェイプの行方向の移動要否を判定する
If (Shape.Top + Shape.Height / 2) <= Range(Shape_Range_TopLeft).Top + Range(Shape_Range_TopLeft).Height Then
    Shape_Offset_Row = 0
Else
    Shape_Offset_Row = 1
End If

'オートシェイプの列方向の移動要否を判定する
If (Shape.Left + Shape.Width / 2) <= Range(Shape_Range_TopLeft).Left + Range(Shape_Range_TopLeft).Width Then
    Shape_Offset_Column = 0
Else
    Shape_Offset_Column = 1
End If

'オートシェイプの移動先のセルをRangeオブジェクトとして取得する
Set Range_Move = Range(Shape_Range_TopLeft).Offset(Shape_Offset_Row, Shape_Offset_Column)


'オートシェイプを移動先のセルの中心に設置する
Shape.Left = Range_Move.Left + Range_Move.Width / 2 - Shape.Width / 2
Shape.Top = Range_Move.Top + Range_Move.Height / 2 - Shape.Height / 2

   
Next Shape
    
End Sub

＜マクロ実行結果＞

このようにセルの中心にオートシェイプの位置を修正することができました。