オートシェープをグルーピングして動作させたい
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
お礼
keithinさん、毎回ありがとうございます。 無事できました。 MSのヘルプは長すぎる上に、わかり辛過ぎてちょっと難しいですね……。