(Excel)オートシェイプどうしの空間を削除する

Excelオートシェイプで画面デザインの仕様を作成してるとたまに欲しくなる。
VSにはあるんだけど何故かExcelにはないんだよね。
ということで作ってみた。

' 左右の間隔削除
'
' □ □　□　　□
' ↓
' □□□□
'
Sub DeleteSpaceHorizontal()
    Dim Sh As Shape
    Dim x As Single
    Dim y As Single
    Dim w As Single
    x = -1

    For Each Sh In Selection.ShapeRange
        If x = -1 Then
            x = Sh.Left
            w = Sh.Width
        Else
            Sh.Left = x + w

            x = Sh.Left
            w = Sh.Width
        End If
    Next Sh
End Sub


' 上下の間隔削除
Sub DeleteSpaceVertical()
    Dim Sh As Shape
    Dim x As Single
    Dim y As Single
    Dim h As Single
    y = -1

    For Each Sh In Selection.ShapeRange
        If y = -1 Then
            y = Sh.Top
            h = Sh.Height
        Else
            Sh.Top = y + h

            y = Sh.Top
            h = Sh.Height
        End If
    Next Sh
End Sub


ついでに複数のオートシェイプでサイズを揃えるマクロも作った。

' 同じサイズに揃える 幅
' (位置は変えない)
'
' [ ][] [  ]   [] → [ ][ ] [ ]   [ ]
'
Sub AlignShapeWidth()
    Dim Sh As Shape
    Dim w As Single
    w = -1

    For Each Sh In Selection.ShapeRange
        If w = -1 Then
            w = Sh.Width
        Else
            Sh.Width = w
        End If
    Next Sh
End Sub


' 同じサイズに揃える 高さ
' (位置は変えない)
Sub AlignShapeHeight()
    Dim Sh As Shape
    Dim h As Single
    h = -1

    For Each Sh In Selection.ShapeRange
        If h = -1 Then
            h = Sh.Height
        Else
            Sh.Height = h
        End If
    Next Sh
End Sub


' 同じサイズに揃える
' (位置は変えない)
Sub AlignShapeSize()
    AlignShapeWidth
    AlignShapeHeight
End Sub