Sub coord()
    Dim a(1 To 4, 1 To 3), i%, j%
    With ActiveSheet.Shapes(1)
        For i = 1 To 4
            a(i, 1) = .Left + .Width / 2
            a(i, 2) = .Top - .Height / 2
        Next
    End With
    
    For i = 1 To ActiveSheet.Shapes.Count
        With ActiveSheet.Shapes(i)
            If .Top - .Height / 2 < a(1, 2) Then a(1, 1) = .Left + .Width / _
                2: a(1, 2) = .Top - .Height / 2: a(1, 3) = .Name
            If .Left + .Width / 2 < a(2, 1) Then a(2, 1) = .Left + .Width / _
                2: a(2, 2) = .Top - .Height / 2: a(2, 3) = .Name
            If .Left + .Width / 2 > a(3, 1) Then a(3, 1) = .Left + .Width / _
                2: a(3, 2) = .Top - .Height / 2: a(3, 3) = .Name
            If .Top - .Height / 2 > a(4, 2) Then a(4, 1) = .Left + .Width / _
                2: a(4, 2) = .Top - .Height / 2: a(4, 3) = .Name
        End With
    Next i
    [Start].Offset(1, 1).Resize(4, 3) = a
End Sub