オートシェイプのコピー（Duplicate） - Infomentのブログ～Excel VBA奮闘記～

ふと、思った。オートシェイプを、Ctrlキーを押しながらクリックするとコピーできるあれ、どのようなコードで書けるのか。
f:id:Infoment:20190119145412g:plain
早速、マクロの記録で確認してみる。
雑味を除くと、こんな感じになった。

Sub Macro1()
    ActiveSheet.Shapes.Range(Array("Oval 1")).Select
    Selection.ShapeRange.Duplicate.Select
    Selection.ShapeRange.IncrementLeft 33.75
    Selection.ShapeRange.IncrementTop 27.75
End Sub

Duplicateというのは、データの重複削除で見かける単語と同じ意味だろうか。今回は重複削除とは逆で、重複させている？だとすると、このような意味になるか。
※その後の調べで、

Duplicate：複製する
Duplication：重複

という意味があると判明。

Sub Macro1()
    ' シート上の楕円１を選択。
    ActiveSheet.Shapes.Range(Array("Oval 1")).Select
    
    ' 選択したオートシェイプを重複させたものを選択。
    Selection.ShapeRange.Duplicate.Select
    
    ' 選択したものの相対位置（左）を38.25へ。
    Selection.ShapeRange.IncrementLeft 38.25
    
    ' 選択したものの相対位置（上）を25.5へ。
    Selection.ShapeRange.IncrementTop 25.5
End Sub

相対位置なので、元の位置からの移動量を指定することになる。これは、なかなか面白そうだ。

ということで、まず「選択する」のを止めてみた。

Sub Macro1()
    Dim Shapes(1) As Shape
        ' 一つ目の楕円を描画。
        Set Shapes(0) = ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 50, 50)
        ' 楕円のスタイルを変更。
            Shapes(0).ShapeStyle = msoShapeStylePreset37
        
        ' 二つ目の楕円を複製。
        Set Shapes(1) = Shapes(0).Duplicate
        ' 二つ目の楕円の位置を変更。
        With Shapes(1)
            .IncrementLeft 38.25
            .IncrementTop 25.5
        End With
End Sub

面白くなってきた。試しに、連続で１０個作ってみよう。
一瞬で１０個できると面白くないので、１個作るごとに一時停止させる。

Sub Macro1()
    Dim Shapes(10) As Shape
        ' 一つ目の楕円を描画。
        Set Shapes(0) = ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 50, 50)
        ' 楕円のスタイルを変更。
            Shapes(0).ShapeStyle = msoShapeStylePreset37
    
    Dim i As Long
        For i = 1 To 10
        ' 0.05秒停止。
            Application.Wait [now()+"0:00:00.05"]
        ' ｉ－１番目の楕円を元に、ｉ番目の楕円を複製。
            Set Shapes(i) = Shapes(i - 1).Duplicate
        ' 二つ目の楕円の位置を変更。
            With Shapes(i)
                .IncrementLeft 38.25
                .IncrementTop 25.5
            End With
        Next
End Sub

f:id:Infoment:20190119151426g:plain

先頭がどれか分かるように、他の色を薄めてみよう。付いてくるのは、３個ぐらいで良いかな。

Sub Macro1()
    Dim Shapes(10) As Shape
        ' 一つ目の楕円を描画。
        Set Shapes(0) = ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 50, 50)
        ' 楕円のスタイルを変更。
            Shapes(0).ShapeStyle = msoShapeStylePreset37
    
    Dim i As Long
        For i = 1 To 10
        ' 0.05秒停止。
            Application.Wait [now()+"0:00:00.05"]
        ' ｉ－１番目の楕円を元に、ｉ番目の楕円を複製。
            Set Shapes(i) = Shapes(i - 1).Duplicate
        ' ｉ－１番目の楕円の透明度を５０％に変更。
            Shapes(i - 1).Fill.Transparency = 0.5
        ' 二つ目の楕円の位置を変更。
            With Shapes(i)
                .IncrementLeft 38.25
                .IncrementTop 25.5
            End With
        ' ４個前の楕円を削除。
            If i >= 4 Then
                Shapes(i - 4).Delete
            End If
        Next
End Sub

f:id:Infoment:20190119152447g:plain

何だか尻尾が残って収まりが悪いので、最後は１個になるようにしてみる。

Sub Macro1()
    Dim Shapes(10) As Shape
        ' 一つ目の楕円を描画。
        Set Shapes(0) = ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 50, 50)
        ' 楕円のスタイルを変更。
            Shapes(0).ShapeStyle = msoShapeStylePreset37
    
    Dim i As Long
        For i = 1 To 10
        ' 0.05秒停止。
            Application.Wait [now()+"0:00:00.05"]
        ' ｉ－１番目の楕円を元に、ｉ番目の楕円を複製。
            Set Shapes(i) = Shapes(i - 1).Duplicate
        ' ｉ－１番目の楕円の透明度を５０％に変更。
            Shapes(i - 1).Fill.Transparency = 0.5
        ' 二つ目の楕円の位置を変更。
            With Shapes(i)
                .IncrementLeft 38.25
                .IncrementTop 25.5
            End With
        ' ４個前の楕円を削除。
            If i >= 4 Then
                Shapes(i - 4).Delete
            End If
        Next
        
        ' 最後の３個を消す。
        For i = 7 To 9
        ' 0.05秒停止。
            Application.Wait [now()+"0:00:00.05"]
        ' ｉ番目の楕円を元に、ｉ番目の楕円を複製。
            Shapes(i).Delete
        Next
End Sub