画像ファイルの縮小画像一覧をExcelシート上に作成してみます。

「ベタ焼き」のようなものです。

「ベタ焼き」とは、まだデジタルカメラがなかった頃、フィルムで大量の写真を撮る方はネガを直接、印画紙の上にならべて現像したようなもので画像の縮小一覧を用意したものですよね。 正式には「コンタクトプリント」とでも言うのでしょうか。「インデックスプリント」なるものも同じような用途のものです。 デジタルカメラでもプリントを自分で行なうような場合にこのような縮小画像をA4版1ページなどにならべて表示させて印刷させたいというような要望があります。 アルバム管理用ソフトでもできることなのでしょうが、Excelシート上でこれを実現できるようなマクロを考えてみましょう。 まずは実現イメージです。

(この画像をクリックすると、このページのサンプルがダウンロードができます。)
マクロの起動で「IMAGE_LIST1」を起動すると「ファイルを開く」のダイアログが表示されるので、表示させたい画像を選択して「開く」をクリックします。 画像ファイルは複数選択できます。
すると処理が行なわれ、シート上に画像の一覧が表示されます。 シート上の画像は横3×縦5個で印刷可能な状態でセル内に元画像の縦横比で縮小されてセルの中央に表示されます。

これをExcelVBAで実現するには？

シート上での画像の取扱い、セルの位置や大きさと画像配置の関係制御、さらに行列に対する画像貼り付け個数による繰り返し制御などを理解する必要があります。
ソースコード内にコメントを入れてありますので参考にして下さい。

'***************************************************************************************************
'   画像一覧                                                        Module1(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'10/03/04(1.00)新規作成
'10/03/07(1.01)初回修正
'20/03/03(1.10)*.xlsm化、他
'20/03/20(1.11)改ページ位置修正、ページ単位画面描画更新を追加
'***************************************************************************************************
Option Explicit

'***************************************************************************************************
'   ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名　：IMAGE_LIST1
'* 機能　　：セルに合わせて画像を貼り付けるサンプル(起動処理)
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2010年03月04日
'* 作成者　：井上　治
'* 更新日　：2020年03月20日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub IMAGE_LIST1()
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim objSh As Worksheet                                          ' 画像一覧シート
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim lngIxEnd As Long                                            ' テーブルINDEX上限
    Dim lngIxPgE As Long                                            ' ページ内最終画像INDEX
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim cntPage As Long                                             ' ページカウンタ
    Dim strFileName As String                                       ' ファイル名
    Dim strFileName2 As String                                      ' ファイル名(パス無)
    Dim vntFileName As Variant                                      ' ファイル名(受け取り)
    '===============================================================================================
    ' [全体前処理]
    vntFileName = Application.GetOpenFilename( _
        "画像ファイル (*.bmp;*.jpg;*.jpeg;*.gif;*.tif),*.bmp;*.jpg;*.jpeg;*.gif;*.tif", _
        1, "画像ファイルの指定(複数選択可)", , True)
    ' キャンセルは終了
    If Not IsArray(vntFileName) Then Exit Sub
    '---------------------------------------------------------------------------
    Set objSh = ThisWorkbook.Worksheets(1)
    Set objFso = New FileSystemObject
    ' 画面描画停止
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    '===============================================================================================
    ' [全体主処理]
    lngRow = 1                                              ' 先頭行
    lngIx = LBound(vntFileName)                             ' 先頭画像INDEX
    lngIxEnd = UBound(vntFileName)                          ' 最終画像INDEX
    lngIxPgE = lngIx
    ' 画像ファイルの全件をループ
    Do While lngIx <= lngIxEnd
        '-----------------------------------------------------------------------
        ' [頁単位前処理]
        cntPage = cntPage + 1                               ' ページカウンタ加算
        Application.StatusBar = CStr(cntPage) & "ページ目処理中．．．．"
        Application.ScreenUpdating = False
        ' 2頁目以降は改ページを挿入
        If cntPage >= 2 Then
            objSh.HPageBreaks.Add Before:=objSh.Cells(lngRow - 3, 1)
        End If
        lngIxPgE = lngIxPgE + 15                            ' ページ内最終画像INDEX(横3件×縦5件)
        '-----------------------------------------------------------------------
        ' [頁単位主処理] ※行方向の繰り返し
        Do While ((lngIx <= lngIxPgE) And (lngIx <= lngIxEnd))
            '-------------------------------------------------------------------
            ' [行単位前処理]
            ' 画像貼り付けセルの行のサイズを変更
            objSh.Cells(lngRow, 1).EntireRow.RowHeight = 140
            ' カラムINDEX初期化
            lngCol = 2
            '-------------------------------------------------------------------
            ' [行単位主処理] ※カラム方向の繰り返し
            Do While ((lngCol <= 6) And (lngIx <= lngIxEnd))
                '---------------------------------------------------------------
                ' [カラム単位処理=1画像単位処理]
                strFileName = vntFileName(lngIx)            ' フルパス名
                strFileName2 = objFso.GetFile(strFileName).Name ' パス無し名(表示用)
                ' 写真貼り付け処理(サブ処理)
                Call GP_SetPicture(objSh, _
                                   objSh.Cells(lngRow, lngCol), _
                                   strFileName, _
                                   strFileName2)
                ' カラムと画像INDEXを加算
                lngCol = lngCol + 2
                lngIx = lngIx + 1
            Loop
            ' 行を加算
            lngRow = lngRow + 3
        Loop
        '-----------------------------------------------------------------------
        ' [頁単位後処理]
        Application.ScreenUpdating = True
        DoEvents
    Loop
    '===============================================================================================
    ' [全体後処理]
    Set objSh = Nothing
    Set objFso = Nothing
    ' 画面描画再開
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
        .StatusBar = False
    End With
    ' 終了メッセージ
    MsgBox "終了しました。", vbInformation
    ' 保存済みにする
    ThisWorkbook.Saved = True
End Sub

'***************************************************************************************************
'   ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名　：GP_SetPicture
'* 機能　　：セルに合わせて画像を貼り付ける(セル単位)
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = 画像一覧シート(Object)
'* 　　　　　Arg2 = 画像収容セル(Object)
'* 　　　　　Arg3 = 画像ファイル名(String)              ※フルパス
'* 　　　　　Arg4 = 画像ファイル名(String)              ※表示用
'---------------------------------------------------------------------------------------------------
'* 作成日　：2010年03月04日
'* 作成者　：井上　治
'* 更新日　：2020年03月03日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_SetPicture(ByRef objSh As Worksheet, _
                          ByRef objR As Range, _
                          ByVal strFileName As String, _
                          ByVal strDspName As String)
    '-----------------------------------------------------------------------------------------------
    Dim objPhoto As ShapeRange                              ' 貼付け画像域
    Dim sngWidth As Single                                  ' 画像サイズ(横)
    Dim sngHeight As Single                                 ' 画像サイズ(縦)
    Dim sngRWidth As Single                                 ' セルサイズ(横)
    Dim sngRHeight As Single                                ' セルサイズ(縦)
    Dim sngRLeft As Single                                  ' セル位置(横)
    Dim sngRTop As Single                                   ' セル位置(縦)
    Dim sngWReduction As Single                             ' 縮小率(横、中間計算値)
    Dim sngHReduction As Single                             ' 縮小率(縦、中間計算値)
    '---------------------------------------------------------------------------
    ' 貼り付け先セルの位置、大きさを取得、枠線を表示
    With objR
        sngRLeft = .Left
        sngRTop = .Top
        sngRWidth = .Width
        sngRHeight = .Height
        .BorderAround xlContinuous, xlThin
    End With
    '---------------------------------------------------------------------------
    ' 一旦画像をシートに貼り付け
    On Error Resume Next
    Set objPhoto = objSh.Pictures.Insert(strFileName).ShapeRange
    ' エラーの場合はエラーメッセージを表示
    If Err.Number <> 0 Then
        objR.Value = "※読込み失敗" & vbLf & Err.Description
        On Error GoTo 0
        ' 画像の下のセルに表示名をセット
        objR.Offset(1).Value = strDspName
        Exit Sub
    End If
    On Error GoTo 0
    '---------------------------------------------------------------------------
    With objPhoto
        ' 画像の元の大きさを取得
        sngWidth = .Width
        sngHeight = .Height
        ' サイズ調整
        If ((sngWidth > sngRWidth) Or (sngHeight > sngRHeight)) Then
            ' 縦横の縮小率を算出
            sngWReduction = (sngRWidth - 3) / sngWidth
            sngHReduction = (sngRHeight - 3) / sngHeight
            ' 小さい方の縮小率でサイズを調整
            If sngWReduction < sngHReduction Then
                sngWidth = sngWidth * sngWReduction
                sngHeight = sngHeight * sngWReduction
            Else
                sngWidth = sngWidth * sngHReduction
                sngHeight = sngHeight * sngHReduction
            End If
            ' 縦横サイズを設定
            .Height = sngHeight
            .Width = sngWidth
        End If
        ' セルの中央に位置を調整
        If sngWidth < sngRWidth Then
            sngRLeft = sngRLeft + (sngRWidth - sngWidth) / 2
        End If
        If sngHeight < sngRHeight Then
            sngRTop = sngRTop + (sngRHeight - sngHeight) / 2
        End If
        ' 位置揃え(セルの中央)
        .Left = sngRLeft
        .Top = sngRTop
    End With
    '---------------------------------------------------------------------------
    ' 画像の下のセルに表示名をセット
    objR.Offset(1).Value = strDspName
End Sub

'----------------------------------------<< End of Source >>----------------------------------------

画像の個数に対するセル位置取得まではメイン処理内でのループ処理(ページ／行／カラムにより3重処理)で行ない、 セルに対する画像貼り付け部分はサブ処理にしてあります。
ループの構造についてはメイン処理記述(IMAGE_LIST1)を参考にしていただき、画像処理についてここでコメントすることにします。

画像貼り付け処理の詳細について

画像貼り付け処理では以下の順で処理を行なっています。

まず、貼り付け先セルの位置(Left,Top)、サイズ(Width,Height)を取得します。

シート上に画像を貼り付けてそのShapeRangeオブジェクトを取得します。

ShapeRangeオブジェクトから画像のサイズ(Width,Height)を取得します。

画像がセルに収まらない場合は収まるサイズにする場合のサイズ(Width,Height)を算出（罫線による余白を3ポイント分考慮）し、 縦横の縮小比で小さいサイズになる方に合わせてサイズを決定し、画像のサイズを変更する。

最後にセル内に合うように位置(Left,Top)を移動させるが、単にLeft、Topプロパティを合わせるだけだとセルの左上に配置されてしまうので、 縦横で余白がある場合にLeft、Topプロパティに対して余白の半分を調整してセルの中央に画像が表示されるように位置させる。

これで指定セルの中央に画像が表示できるようになると思います。

上記の方法では印刷時に「デブ」になる問題がありました。

これはExcelの問題なのでしょうが、画面の見かけと印刷時で縦横比が異なるようです。
まあ、画像処理のためにソフトではないので、これを問題とするわけにもいかないですから、貼り付け画像の方で縦横比を調整しようとしたのですが、 上記の記述で、

  .Width = sngWidth  * 0.9

などとしても縦横比が変わらない状態で変倍されてしまいます。



ShapeRangeオブジェクトではなく、Shapeオブジェクトであれば変倍できるのかも知れませんが、 現状の情報としてはワークシートにShapes.AddPictureメソッドで貼り付けるのであれば、この時点で位置・サイズともに指定できるので 上記のPictures.Insertメソッドで貼り付けた画像から元サイズを取得して一旦削除し、再度Shapes.AddPictureメソッドで貼り付けし直すようにしたのが下記に記述です。

'***************************************************************************************************
'   画像一覧(縦横比変更版)                                          Module2(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'10/03/07(1.00)新規作成
'20/03/03(1.10)*.xlsm化、他
'20/03/20(1.11)改ページ位置修正、ページ単位画面描画更新を追加
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsMagnificate As Single = 0.9                  ' 横変倍倍率

'***************************************************************************************************
'   ■■■ ワークシート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名　：IMAGE_LIST2
'* 機能　　：セルに合わせて画像を貼り付けるサンプル(起動処理)
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2010年03月07日
'* 作成者　：井上　治
'* 更新日　：2020年03月20日
'* 更新者　：井上　治
'* 機能説明：※縦横比変更版
'* 注意事項：
'***************************************************************************************************
Sub IMAGE_LIST2()
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim objSh As Worksheet                                          ' 画像一覧シート
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim lngIxEnd As Long                                            ' テーブルINDEX上限
    Dim lngIxPgE As Long                                            ' ページ内最終画像INDEX
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngCol As Long                                              ' カラムINDEX
    Dim cntPage As Long                                             ' ページカウンタ
    Dim strFileName As String                                       ' ファイル名
    Dim strFileName2 As String                                      ' ファイル名(パス無)
    Dim vntFileName As Variant                                      ' ファイル名(受け取り)
    '===============================================================================================
    ' [全体前処理]
    vntFileName = Application.GetOpenFilename( _
        "画像ファイル (*.bmp;*.jpg;*.jpeg;*.gif;*.tif),*.bmp;*.jpg;*.jpeg;*.gif;*.tif", _
        1, "画像ファイルの指定(複数選択可)", , True)
    ' キャンセルは終了
    If Not IsArray(vntFileName) Then Exit Sub
    '---------------------------------------------------------------------------
    Set objSh = ThisWorkbook.Worksheets(1)
    Set objFso = New FileSystemObject
    ' 画面描画停止
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    '===============================================================================================
    ' [全体主処理]
    lngRow = 1                                              ' 先頭行
    lngIx = LBound(vntFileName)                             ' 先頭画像INDEX
    lngIxEnd = UBound(vntFileName)                          ' 最終画像INDEX
    lngIxPgE = lngIx
    ' 画像ファイルの全件をループ
    Do While lngIx <= lngIxEnd
        '-----------------------------------------------------------------------
        ' [頁単位前処理]
        cntPage = cntPage + 1                               ' ページカウンタ加算
        Application.StatusBar = CStr(cntPage) & "ページ目処理中．．．．"
        Application.ScreenUpdating = False
        ' 2頁目以降は改ページを挿入
        If cntPage >= 2 Then
            objSh.HPageBreaks.Add Before:=objSh.Cells(lngRow - 3, 1)
        End If
        lngIxPgE = lngIxPgE + 15                            ' ページ内最終画像INDEX(横3件×縦5件)
        '-----------------------------------------------------------------------
        ' [頁単位主処理] ※行方向の繰り返し
        Do While ((lngIx <= lngIxPgE) And (lngIx <= lngIxEnd))
            '-------------------------------------------------------------------
            ' [行単位前処理]
            ' 画像貼り付けセルの行のサイズを変更
            objSh.Cells(lngRow, 1).EntireRow.RowHeight = 140
            ' カラムINDEX初期化
            lngCol = 2
            '-------------------------------------------------------------------
            ' [行単位主処理] ※カラム方向の繰り返し
            Do While ((lngCol <= 6) And (lngIx <= lngIxEnd))
                '---------------------------------------------------------------
                ' [カラム単位処理=1画像単位処理]
                strFileName = vntFileName(lngIx)            ' フルパス名
                strFileName2 = objFso.GetFile(strFileName).Name ' パス無し名(表示用)
                ' 写真貼り付け処理(サブ処理)
                Call GP_SetPicture2(objSh, _
                                    objSh.Cells(lngRow, lngCol), _
                                    strFileName, _
                                    strFileName2)
                ' カラムと画像INDEXを加算
                lngCol = lngCol + 2
                lngIx = lngIx + 1
            Loop
            ' 行を加算
            lngRow = lngRow + 3
        Loop
        '-----------------------------------------------------------------------
        ' [頁単位後処理]
        Application.ScreenUpdating = True
        DoEvents
    Loop
    '===============================================================================================
    ' [全体後処理]
    Set objSh = Nothing
    Set objFso = Nothing
    ' 画面描画再開
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
        .StatusBar = False
    End With
    ' 終了メッセージ
    MsgBox "終了しました。", vbInformation
    ' 保存済みにする
    ThisWorkbook.Saved = True
    '---------------------------------------------------------------------------
End Sub

'***************************************************************************************************
'   ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名　：GP_SetPicture2
'* 機能　　：セルに合わせて画像を貼り付ける(セル単位)
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = 画像一覧シート(Object)
'* 　　　　　Arg2 = 画像収容セル(Object)
'* 　　　　　Arg3 = 画像ファイル名(String)              ※フルパス
'* 　　　　　Arg4 = 画像ファイル名(String)              ※表示用
'---------------------------------------------------------------------------------------------------
'* 作成日　：2010年03月07日
'* 作成者　：井上　治
'* 更新日　：2020年03月03日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_SetPicture2(ByRef objSh As Worksheet, _
                           ByRef objR As Range, _
                           ByVal strFileName As String, _
                           ByVal strDspName As String)
    '-----------------------------------------------------------------------------------------------
    Dim objPhoto As ShapeRange                              ' 貼付け画像域
    Dim sngWidth As Single                                  ' 画像サイズ(横)
    Dim sngHeight As Single                                 ' 画像サイズ(縦)
    Dim sngLeft As Single                                   ' 画像位置(横)
    Dim sngTop As Single                                    ' 画像位置(縦)
    Dim sngRWidth As Single                                 ' セルサイズ(横)
    Dim sngRHeight As Single                                ' セルサイズ(縦)
    Dim sngRLeft As Single                                  ' セル位置(横)
    Dim sngRTop As Single                                   ' セル位置(縦)
    Dim sngWReduction As Single                             ' 縮小率(横、中間計算値)
    Dim sngHReduction As Single                             ' 縮小率(縦、中間計算値)
    '---------------------------------------------------------------------------
    ' 貼り付け先セルの位置、大きさを取得、枠線を表示
    With objR
        sngRLeft = .Left
        sngRTop = .Top
        sngRWidth = .Width
        sngRHeight = .Height
        .BorderAround xlContinuous, xlThin
        ' 画像位置を仮決定
        sngLeft = sngRLeft
        sngTop = sngRTop
    End With
    '---------------------------------------------------------------------------
    ' 画像サイズを取得するため一旦画像をシートに貼り付け
    On Error Resume Next
    With objSh.Pictures.Insert(strFileName).ShapeRange
        ' 画像の元の大きさを取得
        sngWidth = .Width
        sngHeight = .Height
        ' サイズ取得後は一旦削除
        .Delete
    End With
    ' エラーの場合はエラーメッセージを表示
    If Err.Number <> 0 Then
        objR.Value = "※読込み失敗" & vbLf & Err.Description
        On Error GoTo 0
        ' 画像の下のセルに表示名をセット
        objR.Offset(1).Value = strDspName
        Exit Sub
    End If
    On Error GoTo 0
    '---------------------------------------------------------------------------
    ' サイズ調整 ※貼り付け後のShapeRangeでは縦横比が変更できないため
    If ((sngWidth > sngRWidth) Or (sngHeight > sngRHeight)) Then
        ' 縦横の縮小率を算出
        sngWReduction = (sngRWidth - 3) / sngWidth
        sngHReduction = (sngRHeight - 3) / sngHeight
        ' 小さい方の縮小率でサイズを調整
        If sngWReduction < sngHReduction Then
            sngWidth = sngWidth * sngWReduction
            sngHeight = sngHeight * sngWReduction
        Else
            sngWidth = sngWidth * sngHReduction
            sngHeight = sngHeight * sngHReduction
        End If
        ' 横幅は印刷用に変倍
        sngWidth = sngWidth * g_cnsMagnificate
    End If
    '---------------------------------------------------------------------------
    ' セルの中央に位置を調整
    If sngWidth < sngRWidth Then
        sngLeft = sngRLeft + (sngRWidth - sngWidth) / 2
    End If
    If sngHeight < sngRHeight Then
        sngTop = sngRTop + (sngRHeight - sngHeight) / 2
    End If
    '---------------------------------------------------------------------------
    ' 指定位置・大きさで写真を再読み込み
    objSh.Shapes.AddPicture Filename:=strFileName, _
                            LinkToFile:=msoFalse, _
                            SaveWithDocument:=msoTrue, _
                            Left:=sngLeft, _
                            Top:=sngTop, _
                            Width:=sngWidth, _
                            Height:=sngHeight
    '---------------------------------------------------------------------------
    ' 画像の下のセルに表示名をセット
    objR.Offset(1).Value = strDspName
End Sub

'----------------------------------------<< End of Source >>----------------------------------------

※なお、画面と印刷時の縦横比の違いは正確に実測したわけではありません。横方向を0.9倍にしたところで見かけ上でだいたいうまくいったというところです。

画像そのもののサイズは縮まりませんでした。

ワークシートに画像を貼り付ける際に画像のサイズは縮小しているのですが、貼り付けた後にそのワックブックを保存させると元の画像ファイルをそのまま貼り付けたようなファイルサイズになってしまいます。
JPEGを操作するようなソフトで再エンコードして縮小しているわけではないので当然なのですが、画像を貼り付けたワークブックを保存させる必要がある場合は、 たとえばフリーソフトの「縮小専用。」のようなものを使って一括で縮小させておいて、その縮小させた画像ファイルの方を取り込むようにすれば良いと思います。
Excelは画像編集ツールにはならないということですね。