Excelワークシートに指定フォルダ（サブフォルダを含む）から画像を読み込んで貼り付けてみた

もうすぐ3月です。
私のいる会社では、月末近くになると年度末の棚卸しがあります。

担当の方がデジカメで写真を撮っては、Excelのワークシートに
ちまちまと貼り付けてはサイズと位置を調整して・・・

面倒くさそうです。（私はその作業に関しては部外者なので関係ないので、他人事）

それ（棚卸）に、完璧に対応するのはとても無理だけど、
少しだけ楽（手抜き？）が出来るかもしれない処理を作ってみました。

やることは、ざっくり言えば、画像の貼り付けとリサイズの半（もう少し少ない？）自動化。

もうちょっと詳しく言えば

1. 画像のあるフォルダを指定出来ること
2. 画像は、指定したフォルダのサブフォルダを含めて抽出できること
3. 画像の並びは、ファイル名ではなく、ファイルのフルパスで昇順とすること
4. 画像を貼り付ける先頭セルを指定できること
5. 画像はセル１個につき１ファイルとすること
6. 貼り付けた画像は、貼り付けるセルの大きさに一致させること（オリジナルと縦横の比率が変わってもOKということ）

といった感じでしょうか。

Option Explicit

'参照設定（FileSystemObject用）
'Microsoft Scripting Runtime

'貼り付けする画像があるフォルダ
Private Const TARGET_FOLDER     As String = "C:\Datas\棚卸写真"

'画像を貼り付けるシート名
Private Const TARGET_SHEET_NAME As String = "Sheet1"

'画像を貼り付ける最初のセルアドレス
Private Const IMAGE_PASET_BEGIN_ADDRESS As String = "B1"

'貼り付けする画像の拡張子
Private Const TARGET_EXT        As String = ".png"


Public Sub addPictures()

    Dim r               As Range
    Dim sTargetPaths()  As String
    Dim i               As Long

    ReDim sTargetPaths(0)

    '指定フォルダにある指定拡張子の画像のパス一覧を取得
    Call getTargetPaths(TARGET_FOLDER, sTargetPaths)

    '画像のパスを昇順で並べ替え
    Call sortArrayList(sTargetPaths)

    '画像を貼り付ける最初のセル
    Set r = ThisWorkbook.Worksheets(TARGET_SHEET_NAME).Range(IMAGE_PASET_BEGIN_ADDRESS)

    '指定のセルに画像を貼り付け
    Call insertImage(sTargetPaths, r)
'    Call insertImage(sTargetPaths, r, 1)

End Sub


'指定フォルダにある指定拡張子の画像のパス一覧を取得
Private Sub getTargetPaths(ByVal sSrcFolder As String, ByRef sTargetPaths() As String)

    Dim fso     As FileSystemObject
    Dim fl      As Folder
    Dim f       As File
    Dim sTargetFolder   As String
    Dim lElements       As Long

    Set fso = New FileSystemObject

    If Not fso.FolderExists(sSrcFolder) Then
        Exit Sub
    End If

    For Each fl In fso.GetFolder(sSrcFolder).SubFolders
        'サブフォルダがあれば、再帰処理
        Call getTargetPaths(fl.Path, sTargetPaths)
    Next fl

    For Each f In fso.GetFolder(sSrcFolder).Files
        '拡張子チェック
        If Right$(LCase(f.Name), Len(TARGET_EXT)) = TARGET_EXT Then
            If Right$(sSrcFolder, 1) = "\" Then
                sTargetFolder = sSrcFolder
            Else
                sTargetFolder = sSrcFolder & "\"
            End If

            lElements = UBound(sTargetPaths)

            If lElements > 0 Then
                lElements = lElements + 1

                ReDim Preserve sTargetPaths(lElements)

                sTargetPaths(lElements) = sTargetFolder & f.Name
            ElseIf lElements = 0 Then
                If sTargetPaths(lElements) = "" Then
                    sTargetPaths(lElements) = sTargetFolder & f.Name
                Else
                    lElements = lElements + 1

                    ReDim Preserve sTargetPaths(lElements)

                    sTargetPaths(lElements) = sTargetFolder & f.Name
                End If
            End If
        End If
    Next f

End Sub

Private Sub sortArrayList(ByRef sDatas() As String)

    Dim ws  As Worksheet
    Dim sortRange   As Range
    Dim vDatas      As Variant
    Dim i           As Long

    With ThisWorkbook.Worksheets.Add
        .Visible = xlSheetHidden

        Set sortRange = .Range("A1").Resize(UBound(sDatas) + 1)

        sortRange = WorksheetFunction.Transpose(sDatas)
        
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=sortRange, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        With .Sort
            .SetRange sortRange
            .Header = xlGuess
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        vDatas = sortRange

        For i = LBound(vDatas) To UBound(vDatas)
            sDatas(i - 1) = CStr(vDatas(i, 1))
        Next i

        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With

End Sub

'画像を貼り付け
'
'   sTargetPaths()  ：貼り付ける画像のパスを格納した配列
'   r               ：画像を貼り付ける最初のセル
'   lIntervalRow    ：画像を貼り付ける間隔（デフォルト０。省略可）
'
Private Sub insertImage(ByRef sTargetPaths() As String, ByRef r As Range, Optional ByVal lIntervalRow = 0)

    Dim rng As Range
    Dim fso As FileSystemObject
    Dim i   As Long

    Set fso = New FileSystemObject

    For i = 0 To UBound(sTargetPaths)
        '画像を貼り付けるセルの位置、サイズ情報取得用
        Set rng = r.Offset((lIntervalRow + 1) * i)

        Call r.Parent.Shapes.AddPicture( _
                Filename:=sTargetPaths(i), _
                LinkToFile:=False, _
                SaveWithDocument:=True, _
                Left:=rng.Left, _
                Top:=rng.Top, _
                Width:=rng.Width, _
                Height:=rng.Height)

        rng.Offset(, 1).Value = fso.GetFileName(sTargetPaths(i))
    Next i

End Sub

画像データはこんな感じ

おにぎりフォルダ

スイーツフォルダ

パンフォルダ

洋食フォルダ

実行結果

実行結果

とりあえず、先頭の定数をいじれば、それなりに使えないかなぁ～

ファイルパスのソートは、一時的に追加したダミーのワークシートに配列から貼り付けて、ワークシート上でソートしてから再度配列に取り込んでます。
データ数が少ないから、セルのデータをフルスキャンしてもいいんだけど、そうしない方向でやってみました。
昔作ったクイックソートのコードを引っ張り出してきても良かったんだけど、いろいろやってみたかったので・・・

サンプルとして使用した素材は、いらすとやよりダウンロードし、使わせていただきました。