サブフォルダ内の画像をサブフォルダ名のシートごとに貼り付けたい

vba

Sub PicInsert()

    Dim FolderPath As String
    FolderPath = Range("A2").Value　　　'A2には\Sampleまでのパスが入っている
    Call FileSearch(FolderPath)

End Sub


Sub FileSearch(FolderPath As String)

    Dim FSO As Object, Folder As Variant
    Dim ws As Worksheet

    Set FSO = CreateObject("Scripting.FileSystemObject")

    For Each Folder In FSO.GetFolder(FolderPath).SubFolders
        Call FileSearch(Folder.Path)
    Next Folder

    For Each File In FSO.GetFolder(FolderPath).Files
        'Debug.Print File.Path
        ActiveSheet.Pictures.Insert File.Path
    Next File

    '貼り付け方の指定プロシージャ
    Call Paste

End Sub

vba

Sub Paste()

      Dim Pic As Variant
      Range("B3").Activate
      For Each Pic In ActiveSheet.Shapes
            Pic.Select
            Pic.LockAspectRatio = msoTrue

            Selection.ShapeRange.Top = ActiveCell.Top + 1
            Selection.ShapeRange.Left = ActiveCell.Left

            Pic.Height = 430
       
            ActiveCell.Offset(25,0).Activate
      Next Pic
End Sub

質問内容が多数ありますので、とりあえず下記の1点だけに絞って回答します。

FSOを使った記述の仕方がわからない。

いろいろ修正点がありますので、コメントで書くコードの意味を説明してあります。
自分のコードとの違いを確認してください。

vba
1Sub PicInsert()
2    '変数はVariant型ではなく適切な型で宣言した方がよい
3    Dim f As Object
4    Dim Path As String
5    Dim FileName As String
6
7    Path = Range("A1").Value                     'セルにあらかじめTestまでのディレクトリを入れておく
8 
9    With CreateObject("Scripting.FileSystemObject")
10        'サブフォルダーを順に取得
11        For Each f In .GetFolder(Path).SubFolders  'サブフォルダーオブジェクトを順に取得          
12            FileName = Dir(f.Path & "\*.png")   'サブフォルダー内のpngファイル名を取得
13            Do Until FileName = ""  '次のファイル名がなくなるまで繰り返す
14
15               'イミディエイトウィンドウにファイルパスを出力
16                Debug.Print f.Path & "\" & FileName
17
18                FileName = Dir() '次のファイル名を取得
19            Loop
20        Next f
21    End With
22
23End Sub

実行してみて、イミディエイトウィンドウに目的のファイル名が出力されているのを確認ください。
コードを意味を理解してください。

上記ができたら、サブフォルダー名でシートの追加、シートへの画像の挿入の処理を追加します。
下記のリンク先が参考になるでしょう。

VBA シートを追加する

エクセルVBAで大量の画像をまとめてシートに貼り付けるAddPictureメソッドの使い方

上記のコードに、下記の処理を追加する参考コードです。

サブフォルダー名で新規シートの追加、追加先は末尾
追加したシートにサブフォルダー内のpng画像を挿入

vba
1Sub PicInsert()
2    '変数はVariant型ではなく適切な型で宣言した方がよい
3    Dim f As Object
4    Dim Path As String
5    Dim FileName As String
6    Dim newWorkSheet As Worksheet
7    Dim targertCell As Range
8
9    Path = Range("A1").Value                     'セルにあらかじめTestまでのディレクトリを入れておく
10 
11    With CreateObject("Scripting.FileSystemObject")
12        'サブフォルダーを順に取得
13        For Each f In .GetFolder(Path).SubFolders  'サブフォルダーオブジェクトを順に取得
14        
15            '新規シートを末尾に追加して名前をフォルダー名に
16            Set newWorkSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
17            newWorkSheet.Name = f.Name
18            Set targertCell = newWorkSheet.Range("A1") '画像挿入セル
19            
20            FileName = Dir(f.Path & "\*.png")   'サブフォルダー内のpngファイル名を取得
21            Do Until FileName = ""  '次のファイル名がなくなるまで繰り返す
22                
23                AddPicture f.Path & "\" & FileName, targertCell
24                Set targertCell = targertCell.Offset(25, 0)  '画像挿入セルを25行下へ移動
25
26                FileName = Dir() '次のファイル名を取得
27            Loop
28        Next f
29    End With
30
31End Sub
32
33'画像挿入サブルーチン
34Sub AddPicture(ImgFileName As String, targertCell As Range)
35    targertCell.Parent.Shapes.AddPicture _
36        FileName:=ImgFileName, _
37        LinkToFile:=False, _
38        SaveWithDocument:=True, _
39        Left:=targertCell.Left, _
40        Top:=targertCell.Top, _
41        Width:=-1, _
42        Height:=-1
43End Sub

同じタグがついた質問を見る

質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう！

サブフォルダ内の画像をサブフォルダ名のシートごとに貼り付けたい

前提

実現したいこと

発生している問題・エラーメッセージ

該当のソースコード

試したこと

関連した質問