はじめに

画像一覧を作って共有したい！貼り付け作業をまとめてやりたい！
そんなときの元ネタになればいいなと作成したマクロになります。
ここからのアレンジは様々なのでベースとして利用してください。

目次

使い方
コード
コード補足
大量のファイルのフルパスの取得方法

使い方

ファイルのフルパスを書いたセルを選択してマクロを実行します。

画像のファイルパスを書いたセルを選択して実行すると、左隣のセルに画像を挿入します。
画像挿入後、一つ下のセルを確認して同様に文字列が書いてあれば,下方向へ繰り返し処理をします。

コード

VBAマクロ

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
'画像を大量に挿入するマクロ
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub PicInsertMacro()
Const PADDING = 6

Dim WorkingCell As Range
Set WorkingCell = ActiveCell

'デバッグ用に行数カウント
'Dim LastRow, WorkingRow As Integer
'WorkingRow = 1
'If WorkingCell.Value <> "" Then LastRow = WorkingCell.End(xlDown).Row - WorkingCell.Row + 1

While WorkingCell.Value <> ""
    'デバッグ用
    'Debug.Print WorkingRow & "/" & LastRow & "|" & WorkingCell.Value
    'WorkingRow = WorkingRow + 1
    
    '画像挿入
    ActiveSheet.Pictures.Insert(WorkingCell.Value).Select
    
    '縦長か横長かでサイズ指定を変える。
    If Selection.Width < Selection.Height Then
        Selection.Height = WorkingCell.Offset(0, -1).Height - PADDING
    Else
        Selection.Width = WorkingCell.Offset(0, -1).Width - PADDING
    End If
    
    'セルの真ん中に移動してきれいに配置する
    Selection.Top = WorkingCell.Offset(0, -1).Top + (WorkingCell.Offset(0, -1).Height - Selection.Height) / 2
    Selection.Left = WorkingCell.Offset(0, -1).Left + (WorkingCell.Offset(0, -1).Width - Selection.Width) / 2
    
    '次のセルに移動する
    Set WorkingCell = WorkingCell.Offset(1, 0)
Wend

'デバッグ用
'Debug.Print "fin"

End Sub

コード補足

基本的には画像一覧を作るためにセルは正方形に近いことを前提に作っています。
PADDINGで余白をつけていて、両サイドの余白の合計を指定する内容になっています。
画像の縦長か横長かを確認して、大きい辺を基準にサイズを決定します

【参考】大量のファイルのフルパスの取得方法

1つのフォルダにファイルが入っている場合(同一フォルダ)

ファイルをすべて選択してから、 Shiftキー を押して右クリックすると、 パスのコピー が可能です。

サブフォルダがある場合ファイルが入っている場合(サブフォルダあり)

コマンドで取得できます

bat

dir /s /b /a-d "対象フォルダ"

REM ファイル数が多い場合には結果をファイルに出力することもできます。
dir /s /b /a-d "対象フォルダ" > "保存したいテキストファイルの保存先"

dir ファイル一覧を取得します
/s サブディレクトリも取得します
/b　ファイルのフルパスを取得します（/sと組み合わせない場合はファイル名のみ）
/a-d　ファイルのみ表示します。　AllからDirectory(フォルダ)を除くので、ALL-Directoryです。

ファイル出力をする場合、画面上に文字は出てこないですが、ファイルに書き込まれています

閲覧ありがとうございました。