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

 1Option Explicit
 2
 3Public Sub Main()
 4
 5  'コピー前にコピー先Sheet2に既に存在する図形をすべて削除したいときは下記のコメントを外す
 6  'Call DeleteAllShapes("Sheet2")
 7  Call CopyShapes("Sheet1", "Sheet2")
 8
 9End Sub
10
11Public Sub CopyShapes(src_sht_name As String, dst_sht_name As String)
12  'コピー元シートの図形をすべてコピーし、コピー先に貼り付ける
13  
14  Dim srcSht As Worksheet
15  Dim dstSht As Worksheet
16  Set srcSht = ThisWorkbook.Worksheets(src_sht_name)
17  Set dstSht = ThisWorkbook.Worksheets(dst_sht_name)
18
19  Dim shp As Shape
20  Dim topY As Double
21  Dim leftX As Double
22  Dim shapeHeight As Double
23  Dim shapeWidth As Double
24  
25  Dim i As Long
26  For i = 1 To srcSht.Shapes.Count
27    topY = srcSht.Shapes(i).Top
28    leftX = srcSht.Shapes(i).Left
29    shapeHeight = srcSht.Shapes(i).Height
30    shapeWidth = srcSht.Shapes(i).Width
31    
32    srcSht.Shapes(i).Copy
33    dstSht.Paste
34    
35    With dstSht.Shapes(dstSht.Shapes.Count)
36      .Top = topY
37      .Left = leftX
38      .Height = shapeHeight
39      .Width = shapeWidth
40    End With
41  Next i
42
43  Set srcSht = Nothing
44  Set dstSht = Nothing
45  Set shp = Nothing
46
47End Sub
48
49Public Sub DeleteAllShapes(sht_name As String)
50  'シートの図形をすべて削除
51
52  Dim sht As Worksheet
53  Set sht = ThisWorkbook.Worksheets(sht_name)
54  
55  Dim shp As Shape
56  For Each shp In sht.Shapes
57    shp.Delete
58  Next shp
59
60End Sub