'図形オブジェクトを同じ位置にコピーするマクロ

'ワークシートまたは図形オブジェクトを選択して、
'DrawingObjectsCopySamePos()マクロを実行してください。

Option Explicit

Const myTitle = "図形オブジェクトの同位置コピー"

Sub DrawingObjectsCopySamePos()

    Const msg1 = "アクティブシート上のすべての図形オブジェクトをコピーします。"
    Const msg2 = "選択されたオブジェクトをコピーします。"
    Const msg3 = "コピー先シートのセルを1つ選択してください。"
    Const msg4 = "ワークシートまたはワークシート上の図形オブジェクトを選択して実行してください。"
    Const msg5 = "アクティブシートには図形オブジェクトがありません。"

    Dim r As Range
    Dim s As String

    On Error GoTo err_1

    '選択オブジェクトの確定
    If TypeName(ActiveSheet) <> "Worksheet" Then
        MsgBox msg4, vbExclamation, myTitle
        Exit Sub
    End If
    If ActiveSheet.DrawingObjects.Count = 0 Then
        MsgBox msg5, vbExclamation, myTitle
        Exit Sub
    End If
    If TypeName(Selection) = "Range" Then
        ActiveSheet.DrawingObjects.Select
        s = msg1 & Chr$(10) & msg3
    Else
        s = msg2 & Chr$(10) & msg3
    End If

    'コピー先シートの選択
    On Error Resume Next
    Set r = Application.InputBox(prompt:=s, Title:=myTitle, Type:=8)
    On Error GoTo err_1
    If r Is Nothing Then Exit Sub

    'コピーの実行
    SelectedObjectsCopySamePos r.Worksheet
    Exit Sub
err_1:
    MsgBox Error(Err), vbExclamation, myTitle
End Sub

Sub SelectedObjectsCopySamePos(sheet1 As Worksheet)
    Dim s As String

    '左上セルのアドレスの取得
    If TypeName(Selection) = "DrawingObjects" Then

        '複数オブジェクトの場合
        Selection.Group.Select
        s = Selection.TopLeftCell.Address
        Selection.Ungroup.Select
    Else

        '1つのオブジェクトの場合
        s = Selection.TopLeftCell.Address
    End If

    '選択オブジェクトのコピー
    Selection.Copy

    '同じ左上セルを選択して貼り付けする
    sheet1.Select
    ActiveSheet.Range(s).Select
    ActiveSheet.Paste
End Sub