VBAで画像挿入を一括実行

久々にコードプログラミングを。
業務でExcelに画像を大量に貼り付けることがあったので、
リサイズや配置間隔、画像の埋め込み等、諸々やってくれるコードを作ってみました。

コード

Sub 画像挿入マクロ()
    Dim ws As Worksheet
    Dim selectedFiles As Variant
    Dim file As Variant
    Dim pic As Shape
    Dim startCell As Range
    Dim i As Long
    Dim cellWidth As Double
    Dim cellHeight As Double
    Dim picRatio As Double
    Dim nextCell As Long

    ' アクティブシートを設定(画像を挿入するシート指定する場合はここを変更)
    Set ws = ActiveSheet
    
    ' 画像を挿入する開始セルを設定（必要に応じて開始セルを変更）
    Set startCell = ws.Range("A1")
    
    ' 挿入する次のセルの間隔を設定（例：下方向に1セルごとに挿入）
    nextCell = 1
    
    ' ファイルダイアログを開いて画像ファイルを選択
    selectedFiles = Application.GetOpenFilename(MultiSelect:=True)
    
    ' ファイルが選択された場合
    If IsArray(selectedFiles) Then
        ' 選択された各ファイルについて処理
        For Each file In selectedFiles
            ' 画像をシェイプとして挿入（画像埋め込み）
            Set pic = ws.Shapes.AddPicture(file, msoFalse, msoCTrue, 0, 0, -1, -1)

            ' セルの幅と高さを取得
            cellWidth = startCell.Width
            cellHeight = startCell.Height

            ' 画像の縦横比を保ちながらリサイズ（セルの横幅に合わせる）
            picRatio = pic.Width / pic.Height
            pic.Width = cellWidth
            pic.Height = cellWidth / picRatio

            ' 画像をターゲットセルの位置に配置
            pic.Top = startCell.Top
            pic.Left = startCell.Left

            ' シェイプの配置オプションを設定 (セル削除や移動に合わせて移動するが、リサイズは行わない)
            pic.Placement = xlMove

            ' 次のセルに移動（横方向に移動したい場合は、nextCell変数を右側に変更）
            Set startCell = startCell.Offset(nextCell, 0)
        Next file

        MsgBox "画像の挿入が完了しました。", vbInformation
    Else
    End If
End Sub

使用例

マクロを起動して、画像を挿入した順番に複数選択する。

選択後に画像をセルの横幅に合わせてリサイズして挿入される。

コード内の変数値をいじると位置や間隔も指定できます。