オートシェープをグルーピングして動作させたい

質問

office365

２つのオートシェープをグルーピングして図形を動作させたい
下記で
kibanは平行四辺形のオートシェープ
yajirushiは右向き矢印のオートシェープ
で、それぞれ、ある範囲で左から右に移動を繰り返します。
この２つのオートシェープをグルーピングして
平行四辺形の右側に矢印を配置した状態で、そのグルーピングされた図形の動作を繰り返す様にしたいのですが、
その内容が分からないのでコードで教えていただきたく、よろしくお願いします。

#If Win64 Then

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

#Else
' Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

#End If

Sub kiban()

shape_delete

Dim ws2 As Worksheet
Dim i As Integer
Set ws2 = Sheets("sheet1")

ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 354, 46, 20).Select

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With

ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 458, 20, 20).Select

ws2.Shapes(ws2.Shapes.Count).name = "kiban"

For i = 0 To 30

If i = 30 Then

i = 0

End If

ws2.Shapes(1).Left = i * 3 + 365

ws2.Shapes(1).Top = 458

Sleep 100
DoEvents

Next i

ws2.Shapes("kiban").delete

End Sub

Sub yajirushi()

shape_delete

Dim ws As Worksheet
Dim i As Integer
Set ws = Sheets("sheet1")

ws.Shapes.AddShape msoShapeRightArrow, 2265, 458, 20, 20

ws.Shapes(ws.Shapes.Count).name = "yajirushi"

For i = 0 To 30

If i = 30 Then

i = 0

End If

ws.Shapes(1).Left = i * 3 + 420

ws.Shapes(1).Top = 458

Sleep 100
DoEvents

Next i

ws.Shapes("yajirushi").delete

End Sub
Sub shape_delete()
Dim shp As Shape
Dim rng As Range

Range("P22:CM28").Select

If TypeName(Selection) <> "Range" Then Exit Sub

For Each shp In ActiveSheet.Shapes
'‘ 図形の配置されているセル範囲をオブジェクト変数にセット
Set rng = Range(shp.TopLeftCell, shp.BottomRightCell)
'‘ 図形の配置されているセル範囲と
'‘ 選択されているセル範囲が重なっているときに図形を削除
If Not (Intersect(rng, Selection) Is Nothing) Then
shp.delete
End If
Next
End Sub

回答No.1

m3_maki · ベストアンサー

グループ化のサンプルです。
グループ化したものは、１つのシェイプとして扱われます。

Sub Sample()
Dim shp1 As Shape
Dim shp2 As Shape
Dim shpG As Shape

' Set shp1 = ActiveSheet.Shapes.AddShape(msoShapeOval, 114.6, 58.8, 72, 72)
' Set shp2 = ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 211.2, 59.4, 83.52, 72)

Set shp1 = ActiveSheet.Shapes.AddShape(msoShapeOval, 114.6, 58.8, 72, 72)
Set shp2 = ActiveSheet.Shapes.AddShape(msoShapeIsoscelesTriangle, 211.2, 59.4, 83.52, 72)

shp2.Fill.ForeColor.RGB = RGB(255, 0, 0)

Set shpG = ActiveSheet.Shapes.Range(Array(shp1.Name, shp2.Name)).Group
shpG.Name = "MaruSankaku"
Debug.Print shpG.GroupItems(1).Name
Debug.Print shpG.GroupItems(2).Name

shpG.Select
End Sub

お礼

ありがとうございます。
Set shpG = ActiveSheet.Shapes.Range(Array(shp1.Name, shp2.Name)).Group

これでうまくいけました。