VBAで図形を別シートの同じ位置へコピーする方法

こんにちは、Ryoです。
Excelで色んな資料を作っていると欠かせないのが図形達ですね。
テキストボックスや矢印、吹出とか四角形等々ありますが場合によっては
その図形達を同じ位置で別のシートにコピーしたいことが稀に良くあります。（どっちだ？）

単一のファイルなら全部選択して他シートに貼れば終わりですが、複数となると結構な
手間になりますから、やっぱり楽に済ませたいものです。
そこで今回は同じ位置で別シートにコピーするVBAコードをご紹介します。

1.サンプルSheet
2.サンプルコード

1.サンプルSheet

Sheet1にこのように4つの図形があったとします。
それらを全てをSheet2枠内の同じ位置にコピーするサンプルコードになります。

【コピー元Sheet１】

【コピー先Sheet2】

次はサンプルコード全体になります。

2.サンプルコード

Sub ShapsMove()

  Dim strName() As Variant
  Dim Sh_A, Sh_B As Worksheet
  Dim Sh_Aname, Sh_Bname, bk As String
  Dim i As Integer

  'ブック名、元Sheet名をSh_A（ワークシートオブジェクト）にセット
  bk = ActiveWorkbook.Name
  Sh_Aname = ActiveSheet.Name
  Set Sh_A = Workbooks(bk).Worksheets(Sh_Aname)

  'この場合末尾シートの為、最終シートを選択
  Worksheets(Worksheets.Count).Select
  'コピー先シート情報をSh_Bにセット
  Sh_Bname = ActiveSheet.Name
  Set Sh_B = Workbooks(bk).Worksheets(Sh_Bname)

  Sh_A.Activate
 
   'コピー元シートの図形をカウントし動的配列にセット
   ReDim strName(1 To ActiveSheet.Shapes.Count)
   Dim Top_y, Left_x, Height_y, Width_x As Double
    
    For i = 1 To ActiveSheet.Shapes.Count
        strName(i) = ActiveSheet.Shapes(i).Name
        
        '//ここから
        Top_y = ActiveSheet.Shapes(strName(i)).Top
        Left_x = ActiveSheet.Shapes(strName(i)).Left
        Height_y = ActiveSheet.Shapes(strName(i)).Height
        Width_x = ActiveSheet.Shapes(strName(i)).Width
        '//ここまでの記述で図形座標を読み込む
        
        '例として図形名の変更（ここはお好きに）
        Sh_A.Shapes(strName(i)).Name = "Fig" & i
        Sh_A.Shapes("Fig" & i).Copy
        Sh_B.Paste
             
           'コピー先図形へ同座標を指定して移動
           '各変数に＋又は－させれば位置の調整も出来ます
           '例）.Left=Left_x + 30 等を指定
           With Sh_B.Shapes("Fig" & i)
               .Left = Left_x
               .Top = Top_y
               .Height = Height_y
               .Width = Width_x
             End With
     Next i
End Sub

今回はサンプルとして、コピー元Sheet内にある図形全てに対し座標を取得して、
コピー先のSheet2に貼付けを行い、取得した座標位置へ移動させるものです。

特定の図形を指定したい場合は、
For i = 1 To ActiveSheet.Shapes.Count
strName(i) = ActiveSheet.Shapes(i).Name
この下にIfやSelect Case等で条件を指定すれば、指定した図形のみを処理できます。
もしテキストボックスであれば、
If InStr(strName(b), “Text”) <> 0 Then等ですね。

ワークシートをSh_A、Sh_Bにセットしてるのは、記述が面倒なのでそうしてますが
ここはお好みで良いと思います。

これを実行するとSheet2（コピー先）へこの通り同じ位置にコピーされます。