画像貼付マクロ、エビデンス貼付けマクロ

あるフォルダに画像ファイルのみを入れる。

マクロ実行前に、貼付を始めるセルを選択しておく。

画像貼付シートの構成は、A列は数字列。B列に貼付けていく。C列は説明列。

1行目は見出し、2行目～11行目結合セル、12～21行目結合セル、22～31行目結合セル、のように10行ごとに結合してる。結合するセルの行数が変わったら、constを変える

Sub PastePictures()
        Application.ScreenUpdating = False
        Dim FSO As New FileSystemObject
        '結合行数（行方向にセル結合してなければ、ketugoGyosu=1でOK）
        Const ketugoGyosu As Long = 10
        
       With Application.FileDialog(msoFileDialogFolderPicker)
                .Title = "画像ファイルだけが入ったフォルダを選択"
                If .Show = True Then
                        Dim myFolderPath As String
                        myFolderPath = .SelectedItems(1)
                Else
                        Exit Sub
                End If
        End With
        
        Dim myFolder As Folder
        Set myFolder = FSO.GetFolder(myFolderPath)
        Dim myFiles As Files
        Set myFiles = myFolder.Files
        
        'マクロ実行前に選択されていたセルの行(i)と列(j)を把握
        Dim i  As Long: i = Selection.Row
        Dim j As Long: j = Selection.Column
        
        Dim myfile As File
        Dim mypic As Shape
        For Each myfile In myFiles
                '隠しファイルを読み込んで貼付失敗したのでその対策
                If myfile.Attributes And Hidden Then    '隠しファイルだったら
                        GoTo myfilenext                 '貼付はスキップして次のファイルへ
                End If
                
                Set mypic = ActiveSheet.Shapes.AddPicture( _
                                Filename:=myfile.Path, _
                                linktofile:=False, _
                                savewithdocument:=True, _
                                Left:=Cells(i, j).MergeArea.Left, _
                                top:=Cells(i, j).MergeArea.top, _
                                Width:=0, _
                                Height:=0)       'ピクセル表現面倒ゆえ、仮に,横０ピクセル縦0ピクセルで。
                                Cells(i, j + 1).Value = myfile.Name
                                
                '縦横比1倍に戻す（ここで1倍にすればピクセル調べずに貼付けられる）
                With mypic
                        .ScaleWidth 1, msoTrue
                        .ScaleHeight 1, msoTrue
                End With
        
                '画像をセルに収めるための倍率（縮小率）
                ' 例　画像が横500縦100、セルが横10縦10の大きさなら、横倍率0.02、縦倍率0.1
                Dim yokoBairitu As Double
                Dim tateBairitu As Double
                yokoBairitu = Cells(i, j).MergeArea.Width / mypic.Width
                tateBairitu = Cells(i, j).MergeArea.Height / mypic.Height
                
                '横と縦の倍率のうち、小さい方の倍率を使えば横も楯もセルに収まる
                If tateBairitu > yokoBairitu Then
                        mypic.Width = mypic.Width * yokoBairitu - 6       '左右余白合計6
                        mypic.Height = mypic.Height * yokoBairitu - 6     '上下余白合計6
                Else
                        mypic.Width = mypic.Width * tateBairitu - 6       '左右余白合計6
                        mypic.Height = mypic.Height * tateBairitu - 6     '上下余白合計6
                End If
        
                '画像を縦横の中央に配置(余白を上下左右均等に割り振る）
                '例　横長画像を正方形セルに入れるなら、左右余白は３ずつになる
                mypic.Left = mypic.Left + (Cells(i, j).MergeArea.Width - mypic.Width) / 2
                mypic.top = mypic.top + (Cells(i, j).MergeArea.Height - mypic.Height) / 2
                '貼付先を１つ下のセル（結合セル）に移動
                i = i + ketugoGyosu
myfilenext:                      '隠しファイルだったら処理スキップして次のファイルへ行く
        Next myfile
        
        Application.ScreenUpdating = False
End Sub