任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい

以前に記載があった内容から、マクロを持ってきましたが、なかなか難易度が高くて、うまくできない状態です。
どなたか分かれば教えてください。

実施したい内容としては、マクロで
①エクセルシートの横列P10,R10,T10,V10,x10,z10,AB10,AD10,AF10,AH10までで1列空ける間隔で（難しい場合は、詰めた状態でもよいです）
　　　　　　　　　　縦列は約50行までの間に,ファルダ内のすべての写真が一括で各セルに画像を挿入
　　　　　　　　　　枚数は約200枚前後
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

'//
Sub 図11R()
　'No. 9024507
　Dim strFilter As String
　Dim Filenames() As Variant
　Dim fName As Variant, ext As String
　Dim PIC As Picture
　Dim k As Long, m As Long
　Dim i As Long, j As Long
　Dim cnt As Long
　Dim FirstRng As Range
　Dim r As Range
　Dim Sel_Folder As Object, Sel_Path As String
　cnt = 0 'カウントの初期値
　'貼り付け最初のセル
　Set FirstRng = Range("A2")
　
　 Set Sel_Folder = CreateObject("Shell.Application"). _
　　　 BrowseForFolder(0, "フォルダを選択してください", 5)

　　If Not Sel_Folder Is Nothing Then
　　　　Sel_Path = Sel_Folder.Self.Path
　　Else
　　　Exit Sub
　　End If
　
　' 「ファイルを開く」ダイアログでファイル名を取得
　ChDir Sel_Path
'　strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
'　Filenames = Application.GetOpenFilename( _
'　FileFilter:=strFilter, _
'　Title:="図の挿入(複数選択可）", _
'　MultiSelect:=True)
　fName = Dir("*.*", vbNormal)
　Do While fName <> ""
　　If fName <> "." And fName <> ".." Then
　　　ext = Mid(fName, InStrRev(fName, ".") + 1)
　　　If InStr(1, "jpg,jpeg,gif,bmp,png", ext, 1) > 0 And Not fName Like "#*" Then
　　　　cnt = cnt + 1
　　　　DoEvents
　　　　ReDim Preserve Filenames(1 To cnt)
　　　　Filenames(cnt) = fName
　　　 ''安全のため（上限を設定)
　　　　If cnt > 100 Then Exit Do
　　　End If
　　End If
　　fName = Dir()
　Loop
　If cnt = 0 Then Exit Sub
　
　' ファイル名をソート
　Call BubbleSort_Str(Filenames, True, vbTextCompare)
　
　'' 貼り付け開始セルを選択
　'Range("B6").Select
　
　' マクロ実行中の画面描写を停止
　Application.ScreenUpdating = False
　' 順番に画像を挿入
　k = LBound(Filenames)
　m = UBound(Filenames)
　
　For j = 1 To Int(m / 4) + Abs(m Mod 4 > 0)
　　For i = 1 To 4
　　　Set PIC = ActiveSheet.Pictures.Insert(Filenames(k))
　　　Set r = FirstRng.Cells(1 + (j - 1) * 2, i)
　　　
　　　'-------------------------------------------------------------
　　　' 画像の各種プロパティ変更
　　　'-------------------------------------------------------------
　　　With PIC
　　　　.Top = r.Top ' 位置：アクティブセルの上側に重ねる
　　　　.Left = r.Left ' 位置：アクティブセルの左側に重ねる
　　　　.Placement = xlMove ' 移動するがサイズ変更しない
　　　　.PrintObject = True ' 印刷する
　　　End With
　　　With PIC.ShapeRange
　　　　.LockAspectRatio = msoTrue ' 縦横比維持
　　　　' 画像の高さをアクティブセルにあわせる
　　　　' 結合セルの場合でも対応
　　　　.Height = r.MergeArea.Height
　　　End With
　　　
　　　' 次の貼り付け先を選択（アクティブセルにする）[例：5個下のセル]
　　　' ActiveCell.Offset(5).Select
　　　
　　　Set PIC = Nothing
　　　k = k + 1
　　　If k >= m Then Exit For
　　Next i
　Next j
　Application.ScreenUpdating = True
　ChDir ThisWorkbook.Path
End Sub

No.3 回答者： fujillin 回答日時： 2020/05/29 09:24

No2です

テストの都合上で、スタートのセルを一行ずらしていたのをそのまま投稿してしまいました。
わかるとは思いますが、念のため訂正しておきます。

誤：Set rng = Cells(11, 16)
正：Set rng = Cells(10, 16)

No.2 回答者： fujillin 回答日時： 2020/05/28 17:09

こんにちは

すでに回答がでていますし、単に「貼り付け位置（セル）を２列置きにする」だけなので、セルの位置を一つおきに制御すれば…と書いても、（多分）通じないのでしょうから、ご質問文の内容に会いそうな内容で作成してみました。

不明なのは（No1様も記述してらっしゃいますが）、貼付けの際のセルサイズと画像サイズの関係です。
およそ二通りの考えがあると思います。
　・縦横比を無視してセルのサイズに合わせる
　・縦横比を維持してできるだけ大きく表示
後者の場合は、余白ができる可能性がありますので、余白をどうするかということも関係してきます。

以下のコードは、とりあえず後者の「縦横比を維持する」例で、位置はセルの左上合わせとしています。
※ 位置やサイズの調整が必要な場合は、「画像ファイル読込みサイズ調整」の部分の修正でできると思います。

Sub Sample_11667960()
Dim dg, ext
Dim fPath As String, fName As String, n As String
Dim rng As Range, i As Integer
Dim sp As Shape, r As Double

ext = Split(".jpg,.jpeg,.gif,.bmp,.png", ",")

Set dg = Application.FileDialog(msoFileDialogFolderPicker)
If Not dg.Show Then Exit Sub
fPath = dg.SelectedItems(1) & "\"
Set rng = Cells(11, 16)

fName = Dir(fPath & "*")
While fName <> ""

n = LCase(fName)
For i = 0 To UBound(ext)
　If Right(n, Len(ext(i))) = ext(i) Then
　　
　' 画像ファイル読込みサイズ調整
　　Set sp = ActiveSheet.Shapes.AddPicture(fPath & fName, _
　　　　　　 False, True, rng.Left, rng.Top, 0, 0)
　　sp.ScaleWidth 1, True
　　sp.ScaleHeight 1, True
　　sp.LockAspectRatio = True
　　r = Application.Min(rng.Width / sp.Width, rng.Height / sp.Height)
　　sp.ScaleWidth r, True
　　sp.ScaleHeight r, True

　　Set rng = rng.Offset(, 2)
　　If rng.Column > 34 Then Set rng = rng.Offset(1, -20)
　　Exit For
　End If
Next i
fName = Dir()
Wend

End Sub

この回答へのお礼

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

お礼日時：2020/06/05 09:45

No.1 回答者： Qchan1962 回答日時： 2020/05/28 14:19

①エクセルシートの横列P10,R10,T10,V10,x10,z10,AB10,AD10,AF10,AH10までで1列空ける間隔で（難しい場合は、詰めた状態でもよいです）

　　　　　　　　　　縦列は約50行までの間に,ファルダ内のすべての写真が一括で各セルに画像を挿入枚数は約200枚前後
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される

②は、問題ないのでは？、
③は、すべてではないような？And Not fName Like "#*" Then　なので数字が頭にあるとダメ？
④は、
　　　　.LockAspectRatio = msoTrue ' 縦横比維持
　　　　' 画像の高さをアクティブセルにあわせる
　　　　' 結合セルの場合でも対応
　　　　.Height = r.MergeArea.Height

なので幅が合わない可能性があります。
縦横比維持しなくて良い？又は大きい方に合わせる？
維持しなくて良ければ
.LockAspectRatio = msoFalse
.Height = r.MergeArea.Height
.Width = r.MergeArea.Width
大きい方に合わせる？は　If文で
.LockAspectRatio = msoTrue ' 縦横比維持
If .Height >= .Width Then
　.Height = r.MergeArea.Height
Else
　.Width = r.MergeArea.Width
End If

①は、やり方は色々あるかと思いますが、変数nを追加して
　　' 順番に画像を挿入
　　k = LBound(Filenames)
　　n = 0
　　For j = LBound(Filenames) To UBound(Filenames)
　　　　For i = 0 To 9
　　　　　　Set Pic = ActiveSheet.Pictures.Insert(Filenames(k))
　　　　　　Set r = FirstRng.Cells(9 + n, 16 + i * 2)

・
・
　　　　　　Set Pic = Nothing
　　　　　　k = k + 1
　　　　　　If k > UBound(Filenames) Then GoTo PicEND
　　　　Next
　　　　n = n + 1
　　Next
PicEND:
　　Application.ScreenUpdating = True
　　ChDir ThisWorkbook.Path
End Sub

ソートの部分など他の部分は分かりません。
未検証なので間違いがあるかも知れません。参考まで

この回答へのお礼

御礼が遅くなり申し訳ありません。有難う御座いました。早速試してみたいと思います。

お礼日時：2020/06/02 11:15