図形を枠線（グリッド）に合わせるマクロ

１　内容

　挿入した図形の上下左右を自動的に最も近い枠線に合わせる形で大きさを調整する。つまり、図形の端を枠線に合わせる。

２　動機

　業務フロー図、手順書をExcelで作る際、図形を枠線に合わせるのが面倒。

３　元ネタ　

gpsoft.dip.jp

本職の方なのでスマートな記載なのだが、VBEに貼り付けても動かず。また「Pos2D」という型がわからなかった。Position2Dだろうから、XYの二次元座標を持たせているだろうことは想像できる。Excelマクロで動作するようにした。

対象の図形（複数OK）を選択した状態でマクロを実行することに注意する。

４　コード

Option Explicit
'------------------------------------------------------------------
'機能：選択した図形を最寄りの枠線に自動吸着
'使い方：クリックや「オブジェクトの選択」機能などで、吸着する対象の図形を選択した状態で実行する
'-----------------------------------------------------------------
Sub fitShapesToGrid()
    Dim LeftandTopToFit As Variant '左端位置、上端位置の二次元配列
    Dim RightandBottomToFit As Variant '右端位置、下端位置の二次元配列
    
    Dim iShape As Shape
    For Each iShape In ActiveWindow.Selection.ShapeRange
        With iShape
            '「iShapeの左上の地点」と「その地点が存在するセル（の4つ角）」を比較して最寄りの角のXY座標(2次元配列）を求める
            LeftandTopToFit = findNearestCorner( _
                                .Left, _
                                .Top, _
                                .TopLeftCell)
            '左端を最寄りの枠線にフィット
            .Left = LeftandTopToFit(0)
            '上端を最寄りの枠線にフィット
            .Top = LeftandTopToFit(1)
            
            '「iShapeの右下の地点」と「その地点が存在するセル（の4つ角）」を比較して最寄りの角のXY座標(2次元配列）を求める
            RightandBottomToFit = findNearestCorner( _
                                    .Left + .Width, _
                                    .Top + .Height, _
                                    .BottomRightCell)
            '右端を最寄りの枠線にフィット
            .Width = RightandBottomToFit(0) - .Left
            '下端を最寄りの枠線にフィット
            .Height = RightandBottomToFit(1) - .Top
        End With
    Next
End Sub

'-----------------------------------------------------------------------------
'機能：地点(x、y)と、１つのセルの4つ角を比較して、最寄りの角を探す。
'変数：X/横位置、Y/縦位置、myCell/任意のセル
'戻り値：最寄りの角の位置（nearestX/横位置、nearestY/縦位置、の2次元配列）
'-----------------------------------------------------------------------------
Private Function findNearestCorner( _
    X As Double, _
    Y As Double, _
    myCell As Range) As Variant
    
    '横位置nearestXを取得
    Dim nearestX As Double
    '「Xとセルの左端」か「Xとセルの右端」どちらが遠いか比較して、近い方の位置を取得
    If Abs(X - myCell.Left) > Abs(X - (myCell.Left + myCell.Width)) Then
        nearestX = myCell.Left + myCell.Width
    Else
        nearestX = myCell.Left
    End If
    
    '縦位置nearestYを取得
    Dim nearestY As Double
    '「Yとセルの上端」か「Yとセルの下端」どちらが遠いか比較して、近い方の位置を取得
    If Abs(Y - myCell.Top) > Abs(Y - (myCell.Top + myCell.Height)) Then
        nearestY = myCell.Top + myCell.Height
    Else
        nearestY = myCell.Top
    End If
    
    '配列に格納
    findNearestCorner = Array(nearestX, nearestY)
End Function

 ５　図形の大きさを変えずに単に左上の枠線に合わせるだけなら。

　元ネタ

vbabeginner.net

選択図形が１つのみか２つ以上で場合分けされているが、shapeRangeオブジェクトを使えばまとめられるので整理してみた。

６　コード

Option Explicit
Sub moveToUpperLeftCorner()
    On Error GoTo ERR
    Dim iShape As shape
    For Each iShape In ActiveWindow.Selection.ShapeRange
        iShape.Top = iShape.TopLeftCell.Top
        iShape.Left = iShape.TopLeftCell.Left
    Next
    Exit Sub

ERR:
    MsgBox "図形が選択されていません"
End Sub