削除した写真より下の写真を上に詰める

質問

よろしくお願いします。

連続した工事写真があります。
不特定位置の写真を1枚削除したときに
その写真より下にある写真を上に詰める。

下の構文（参考文コペピ）で1枚削除、この後が解りません。
Private Sub CommandButton1_Click()
Dim Pic As picture
Dim r As Range
If UCase$(TypeName(Selection)) <> "RANGE" Then Exit Sub
For Each Pic In ActiveSheet.Pictures
Set r = Range(Pic.TopLeftCell, Pic.BottomRightCell)
If Selection.Address = Union(Selection, r).Address Then
Pic.Delete
End If
Set r = Nothing
Next
End Sub

補足
写真は、Ｃ4、Ｃ9，Ｃ14・・・（枚数は変動）と、5行置きに入っています。
その中で、Ｃ9の写真を削除したときにＣ14以降の写真（枚数は変動）を、Ｃ9を先頭にして移動させる。

Ｃ4はそのまま
↓
Ｃ9削除
↓
Ｃ14の写真をＣ9へ
↓
Ｃ19の写真をＣ14へ
↓
Ｃ24の写真をＣ19へ
↓
枚数分繰り返し

下手な説明ですが、よろしくお願いします。

回答No.1

watabe007 · ベストアンサー

参考に
　　If UCase$(TypeName(Selection)) <> "RANGE" Then Exit Sub
　　myRow = Selection(1).Row
　　For Each Pic In ActiveSheet.Pictures
　　　　Set r = Range(Pic.TopLeftCell, Pic.BottomRightCell)
　　　　If Selection.Address = Union(Selection, r).Address Then
　　　　　　Pic.Delete
　　　　ElseIf Pic.TopLeftCell.Row > myRow Then
　　　　　　Pic.Top = Pic.TopLeftCell.Offset(-5).Top
　　　　End If
　　　　Set r = Nothing
　　Next
End Sub

お礼

早速のご回答ありがとうございました。
私の思い通りにできました。

回答No.3

watabe007

アップされたコードでは範囲を選択して範囲内の写真を削除していますね
>不特定位置の写真を1枚削除したときに
この場合、写真を選択して削除した方が良いのでは
※コマンドボタンのTakeFocusOnClickプロパティをFALSE に設定してください。
Private Sub CommandButton1_Click()
　　Dim Pic As Variant
　　Dim myRow As Long
　　If TypeName(Selection) <> "Picture" Then Exit Sub
　　myRow = Selection.TopLeftCell.Row
　　Selection.Delete
　　For Each Pic In ActiveSheet.Pictures
　　　　If Pic.TopLeftCell.Row > myRow Then
　　　　　　Pic.Top = Pic.TopLeftCell.Offset(-5).Top
　　　　End If
　　Next
End Sub

お礼

早速のご回答ありがとうございました。
写真を選ぶ方法もあったのですね。
参考にさせていただきます。

回答No.2

chayamati

おはようございます。
VBAは分かりませんが、Pic.Deleteは実行できましたか？
これに伴い、
9行目から13行目迄も不要ではないですか
これらの行も削除して不都合はありますか
Rows("9:13").Select
Selection.Delete Shift:=xlUp

お礼

早速のご回答ありがとうございました。
削除すると、その列の文言まで消えてしまいますので
不都合です。