Excelの図の位置をセルの中心に

写真や図形をセルの中心に並べたい

Excelは表形式のデータを柔軟に編集できるため、簡単なレイアウトツールやワープロ替わりに使うことができます（是非はさておき）。

表形式に図形を並べる場合、セルの枠線を表の線として利用すると思うのですが、図形と枠線の間に適当な余白を設ける場合、図形をセルの中心に持ってきたくなりますが、いちいち手作業で修正するのは大変です。

そこで、図形を選択して実行するだけで、図形の中心をセルの中心に合わせるマクロを作成しました。

使い方

1. 位置を調整する図形を選びます。
   図形は１つでも複数でも構いません。
2. マクロcenterObjectToCellを実行します。
   選択された図形は、その図形の中心とセルの中心の距離が最小となるセルの中央に移動します。

コード

ユーザー定義関数centerCellを使用して求めたセルの位置に図形の位置を合わせています。

found, known and done / Excelのオブジェクトの中心にあるセルを求める
foundknownanddone.blogspot.jp/2014/04/excel.html 

Sub centerObjectToCell()
    Select Case TypeName(Selection)
        Case "DrawingObjects"
            For Each targetObject In Selection
                Call subroutineCenterObjectToCell(targetObject)
            Next
        Case "Range", "Nothing"
            MsgBox Prompt:="Select shapes or charts on worksheet.", Title:="centerObjectToCell"
        Case Else
            Call subroutineCenterObjectToCell(Selection)
    End Select
End Sub

Sub subroutineCenterObjectToCell(ByRef targetObject As Variant)
    With centerCell(targetObject)
        targetObject.Top = .Top + .Height / 2 - targetObject.Height / 2
        targetObject.Left = .Left + .Width / 2 - targetObject.Width / 2
    End With
End Sub

Function centerCell(ByRef targetObject As Variant) As Range
    Dim targetRange As Range
    Dim minIndex As Integer, minDistance As Double
    Dim originY As Double, originX As Double, targetY As Double, targetX As Double
    
    With targetObject
        Set targetRange = Range(.TopLeftCell, .BottomRightCell)
        
        originY = .Top + .Height / 2
        originX = .Left + .Width / 2
    End With
    
    With targetRange
        minDistance = Sqr(.Height ^ 2 + .Width ^ 2)
        
        For i = 1 To .Cells.Count
            targetY = .Cells(i).Top + .Cells(i).Height / 2
            targetX = .Cells(i).Left + .Cells(i).Width / 2
            
            distance = Sqr((targetY - originY) ^ 2 + (targetX - originX) ^ 2)
            If distance < minDistance Then
                minIndex = i
                minDistance = distance
            End If
        Next
        
        Set centerCell = .Cells(minIndex)
    End With
End Function