途中に画像を挿入マクロ

画像を連続で貼り付けていて、途中で画像を貼り忘れた時に使えそうなマクロを作成。

Sub 途中に画像を挿入マクロ()
    Dim CB As Variant
    Dim i As Long
    Dim lastImg As Integer
    Dim imgHeight As Double
    Dim moveCell As Integer
    Dim cellRow As Long
    Dim insertRow As Long
    
    CB = Application.ClipboardFormats
    
    If CB(1) = True Then
        MsgBox "クリップボードは空です", 48
        Exit Sub
    End If
    
    For i = 1 To UBound(CB)
        If CB(i) = xlClipboardFormatBitmap Then
                    
            '行を1行挿入する
            Rows(ActiveCell.Row).Insert
            
            'セルの移動
            ActiveCell.Offset(1, 0).Activate
        
            '画像貼り付け
            ActiveSheet.Paste
            
            '最後に貼った画像を選択
            lastImg = ActiveSheet.Shapes.Count
            ActiveSheet.Shapes(lastImg).Select
            
            '画像の高さを取得
            imgHeight = Selection.Height
            
            '現在のセルの行を取得
            cellRow = ActiveCell.Row
            
            '挿入する行の数を計算
            insertRow = imgHeight \ ActiveCell.RowHeight
            
            '行を挿入する
            Range(cellRow + 1 & ":" & (cellRow + insertRow + 1)).Insert
            
            'セルの移動数を計算
            moveCell = insertRow + 1

            'セルの移動
            ActiveCell.Offset(moveCell, 0).Activate

            Exit For
        End If
    Next i

End Sub

画像と画像の間にセルを合わせて……。

画像間に挿入される。