セルの値=サブフォルダ名の時写真を張り付ける

Question

初心者質問で申し訳ございません。

Excel上で簡単に複数の写真を張り付けるVBAを作っております。
Excelで写真一覧表を作成しており、作品のタイトルを(y, 2)に入力しております。
メインフォルダをパスで指定を行い、(y, 2)のセルの値のサブフォルダを(y, 11)に貼付けができればと思って作っております。

写真はタイトルごとにサブフォルダを作成し、その中に一枚のみ入れてあります。
イメージとしては

「写真」フォルダ（サブフォルダをまとめている親フォルダ）
↓
「(y, 2)」サブフォルダ(写真を一枚のみ格納)
「(y, 3)」
「(y, 4)」
「(y, 5)」　・・・・・・・
といったイメージです。

親フォルダのファイルパスはInputBoxにて指定を行い、
その他は(y, 2)のセル内の値と同じサブフォルダから写真を貼り付けができればと思います。

途中までは作成ができたのですが、(y, 2)の値を用いてサブフォルダをパス指定を行うことが難しく挫折しております。

初心者で申し訳ございませんがご教授をいただきたく思います。

以下に作成したコードを載せます。
作成した内容は親フォルダをパス指定し、その中にあるサブフォルダを上から順に貼付けるという内容です。

コード
```Sub 写真貼り付け()

Dim alert As VbMsgBoxResult
    alert = MsgBox("実行してよろしいですか？", vbYesNo + vbQuestion, "実行確認")
    If alert = vbYes Then
    
    MsgBox "親フォルダのパスを入力してください。"   '←「はい」ボタンをクリックしたときの処理。
    End If
    
    ' 親フォルダのパス
    root_dir = InputBox("親フォルダーのパス名の入力" + Chr(10) + "例：写真", "親フォルダー確認") & "\"
    
    ' フォルダ内のサブフォルダをスキャン
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sub_dirs = fso.GetFolder(root_dir).SubFolders
    y = 2
    For Each sub_dir In sub_dirs
        ' このサブフォルダについて処理
        y = importImagesFromOneSubDir(sub_dir, y, root_dir)
    Next
 
End Sub


' ある一つのサブフォルダについての処理
Private Function importImagesFromOneSubDir(sub_dir, y, root_dir)
    'MsgBox sub_dir.Name
    
    ' このフォルダ内の画像をすべて列挙
    file_name = Dir(sub_dir & "\*.*")
    Do While file_name <> ""
        ' このファイルの拡張子を調べる
        If isImageFile(file_name) Then
            ' 画像であれば，取り込んで次の行へ
            importImageFile file_name, y, root_dir, sub_dir
            y = y + 1
        End If
        
        ' 次のファイルを取得
        file_name = Dir()
    Loop
        
    ' 現在の行を返す
    importImagesFromOneSubDir = y
    
End Function
        

' 画像ファイルかどうか，拡張子で判定する
Private Function isImageFile(file_name)
    
    ' ピリオドは後ろから何文字目か
    pos_period = InStrRev(file_name, ".")
    If pos_period > 0 Then
        ' 拡張子を切り出し
        file_ext = LCase(Mid(file_name, pos_period + 1))
        
        ' 画像の拡張子か？（小文字で指定可）
        If _
            file_ext = "jpg" Or _
            file_ext = "jpeg" Or _
            file_ext = "bmp" Or _
            file_ext = "gif" Or _
            file_ext = "png" _
        Then
            ' 画像であると判定
            ret = True
        Else
            ret = False
        End If
    Else
        ret = False
    End If
    
    isImageFile = ret
End Function


' ある一つの画像ファイルをシート中に取り込む
Private Sub importImageFile(file_name, y, root_dir, sub_dir)
    file_path = sub_dir & "\" & file_name
    

   
  ActiveSheet.Cells(y, 11).Select
  Set MyShape = ActiveSheet.Shapes.AddPicture( _
          Filename:=file_path, _
          LinkToFile:=False, _
          SaveWithDocument:=True, _
          Left:=Selection.Left + 3.4, _
          Top:=Selection.Top + 3, _
          Width:=Application.CentimetersToPoints(4.55), _
          Height:=Application.CentimetersToPoints(3.41))
          
 
End Sub

Comments

[meg_]

コードは関数毎に「コードの挿入」で記入いただけないでしょうか。
また現状どこまで実現できているのでしょうか？

[bonta]

ありがとうございます。
現状実現できているのは
・親フォルダをinputBoxにて指定
・サブフォルダを開けるための繰り返し処理
・エクセル上での(y, 11)を用いた写真貼り付け位置、写真貼り付けサイズ

できていないことは
・サブフォルダを(y, 2)のセルの値を利用してファイルパスを指定することです。

Answer 1

こういうことですか？

    ' フォルダ内のサブフォルダをスキャン
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    y = 2
    Dim s
    For Each s In Range("B2:B" & Rows.Count).SpecialCells(xlCellTypeConstants)
        If fso.FolderExists(fso.BuildPath(root_dir, s)) Then
            Set sub_dir = fso.GetFolder(fso.BuildPath(root_dir, s))
            y = importImagesFromOneSubDir(sub_dir, y, root_dir)
        End If
    Next

Comments

[bonta]

ありがとうございます！
今試してみたところ無事動いております。
イメージではセルの値がサブフォルダの値と違った場合、そのセルを無視して次のセルに行くことを考えておりました。
この場合はon Error Resume Nextを用いて次のセルの処理を開始するという考えでよろしいでしょうか。

[bonta]

セルの値と同じサブフォルダがある場合は(y, 11)に写真を貼る。
もしない場合は空白にするという意味です。

[jinoji]

If fso.FolderExists(fso.BuildPath(root_dir, s)) Then
Set sub_dir = fso.GetFolder(fso.BuildPath(root_dir, s))
y = importImagesFromOneSubDir(sub_dir, y, root_dir)
Else
y = y + 1
End If

[bonta]

ありがとうございます！
動かしながら勉強もさせていただきました！
親切丁寧に教えていただきありがとうございました！