VBA｜写真・画像が貼ってある行を１段(１行)下げるVBA | ブイサバ【Excel VBAサバイバル】～とりあえずここに来れば解決できる～

エクセルのワークシート上に画像や写真を貼り付けて、アルバムのようにしているものをよく目にします。

順序よく画像や写真をシート上に貼っていたものの、あとから画像を追加したくなるときがあります。

その場合に、下図のように挿入したい位置以降にあるすべての画像を全体的に一行下に下げるマクロを紹介します。

貼ってある画像を、指定する行から全体的に１行したに移動するVBAです。

Sub 一段下げ()

Dim shp_rng As Range

Dim inp_cell As Range


''インプットボックスで、一段下げるセルを選択する
On Error Resume Next
Set inp_cell = Application.InputBox(prompt:="マウスで一段空ける行（セル）を選択してください。", _
                                   Title:="始点セルを選択", _
                                    Default:="マウスでセルを選択", _
                                   Type:=8)
                                   
If Err.Number = 0 Then
    MsgBox myRange.Address
Else
    MsgBox "キャンセルされました。"
    Exit Sub
End If
                                   
                                   
''画像貼りつけ場所以外のセルを選択した場合は、処理をやめる。
If inp_cell.Column > 5 Then
   MsgBox "選択セルが正しくありません。"
   Exit Sub
End If


Dim idousaki_cell As Range
Dim idousaki_cell_row As Long
Dim idousaki_cell_column As Long
Dim s As Long

For idousaki_cell_row = 50 To inp_cell.Row Step -1
   For idousaki_cell_column = 1 To 5
      For s = 1 To ActiveSheet.Shapes.Count
         With ActiveSheet.Shapes(s)
         Set shp_rng = Range(.TopLeftCell, .BottomRightCell)
         
         If Not Intersect(ActiveSheet.Cells(idousaki_cell_row, idousaki_cell_column), shp_rng) Is Nothing Then
            
            idousaki_cell_row = idousaki_cell_row + 1  ''移動先セルを、一行下に設定する
            Set idousaki_cell = Cells(idousaki_cell_row, idousaki_cell_column)
            
            .Left = idousaki_cell.Left
            .Top = idousaki_cell.Top
            .Left = .Left + (idousaki_cell.Width - .Width) / 2
            .Top = .Top + (idousaki_cell.Height - .Height) / 2
            idousaki_cell_row = idousaki_cell_row - 1  ''一行下に設定した値をもとに戻す
            
            Exit For
         End If
         End With
         Next s
      Next idousaki_cell_column
   Next idousaki_cell_row

End Sub

このVBAを実行すると、インプットボックスが立ち上がります。