【VBA】図形を別シートにコピーする

Option Explicit

Public Sub Main()

  'コピー前にコピー先Sheet2に既に存在する図形をすべて削除したいときは下記のコメントを外す
  'Call DeleteAllShapes("Sheet2")
  Call CopyShapes("Sheet1", "Sheet2")

End Sub

Public Sub CopyShapes(src_sht_name As String, dst_sht_name As String)
  'コピー元シートの図形をすべてコピーし、コピー先に貼り付ける
  
  Dim srcSht As Worksheet
  Dim dstSht As Worksheet
  Set srcSht = ThisWorkbook.Worksheets(src_sht_name)
  Set dstSht = ThisWorkbook.Worksheets(dst_sht_name)

  Dim shp As Shape
  Dim topY As Double
  Dim leftX As Double
  Dim shapeHeight As Double
  Dim shapeWidth As Double
  
  Dim i As Long
  For i = 1 To srcSht.Shapes.Count
    topY = srcSht.Shapes(i).Top
    leftX = srcSht.Shapes(i).Left
    shapeHeight = srcSht.Shapes(i).Height
    shapeWidth = srcSht.Shapes(i).Width
    
    srcSht.Shapes(i).Copy
    dstSht.Paste
    
    With dstSht.Shapes(dstSht.Shapes.Count)
      .Top = topY
      .Left = leftX
      .Height = shapeHeight
      .Width = shapeWidth
    End With
  Next i

  Set srcSht = Nothing
  Set dstSht = Nothing
  Set shp = Nothing

End Sub

Public Sub DeleteAllShapes(sht_name As String)
  'シートの図形をすべて削除

  Dim sht As Worksheet
  Set sht = ThisWorkbook.Worksheets(sht_name)
  
  Dim shp As Shape
  For Each shp In sht.Shapes
    shp.Delete
  Next shp

End Sub