'図形オブジェクトをセルの枠線に一括して合わせるマクロ

'セルまたは図形オブジェクトを選択し、ObjectFitマクロを実行してください。
'セルを選択して実行した場合はシート上のすべての図形オブジェクトを
'対象にします。

Option Explicit

Sub ObjectFit()
    Const myTitle = "オブジェクトをセルに合わせる"
    Dim obj As Object

    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

    Select Case TypeName(Selection)
        Case "DrawingObjects"
            Application.ScreenUpdating = False
            For Each obj In Selection
                ObjectFit2 obj
            Next
        Case "Range"
            If MsgBox("アクティブシートのすべての図形オブジェクトをセルに" & _
                "合わせます。" & Chr$(10) & "元に戻すことはできません。", _
                vbExclamation Or vbOKCancel, myTitle) <> vbOK Then Exit Sub
            Application.ScreenUpdating = False
            For Each obj In ActiveSheet.DrawingObjects
                ObjectFit2 obj
            Next
        Case Else
            Application.ScreenUpdating = False
            For Each obj In ActiveSheet.DrawingObjects
                If obj.Name = Selection.Name Then
                    ObjectFit2 obj
                    Exit For
                End If
            Next
    End Select
    Application.ScreenUpdating = True
End Sub

Sub ObjectFit2(obj As Object)
    Dim r As Range
    Set r = GetObjectRange2(obj)
    obj.Left = r.Left
    obj.Top = r.Top
    obj.Width = r.Width
    obj.Height = r.Height
End Sub

Function GetObjectRange2(obj As Object) As Range
    Dim rng1 As Range, rng2 As Range, rng3 As Range
    Dim rowSize As Integer, colSize As Integer
    Dim objRight As Double, objBottom As Double

    objRight = obj.Left + obj.Width
    objBottom = obj.Top + obj.Height
    Set rng1 = obj.TopLeftCell
    Set rng2 = obj.BottomRightCell
    rowSize = rng2.Row - rng1.Row + 1
    colSize = rng2.Column - rng1.Column + 1

    If (rng1.Top + rng1.Height / 2 < obj.Top) _
            And (rowSize > 1) Then
        Set rng1 = rng1.Offset(1)
    End If
    If (rng1.Left + rng1.Width / 2 < obj.Left) _
            And (colSize > 1) Then
        Set rng1 = rng1.Offset(, 1)
    End If

    Set rng3 = rng1.Worksheet.Range(rng1, rng2)
    rowSize = rng3.Rows.Count
    colSize = rng3.Columns.Count

    If (rng3.Top + rng3.Height - rng2.Height / 2 > objBottom) _
            And (rowSize > 1) Then
        Set rng3 = rng3.Resize(rowSize - 1)
    End If
    If (rng3.Left + rng3.Width - rng2.Width / 2 > objRight) _
            And (colSize > 1) Then
        Set rng3 = rng3.Resize(, colSize - 1)
    End If
    Set GetObjectRange2 = rng3
End Function