excelファイルを検索してセル内容を転記する方法

質問

VBA初心者です。
Aというディレクトリがあり、その中に1,2,3,4というフォルダがあります。
1には「apple1.csv」、「orange1.csv」、「banana1.csv」
2には「apple2.csv」、「orange2.csv」、「banana1.csv」
・・・
4には「apple4.csv」、「orange4.csv」、「banana4.csv」
が入っています。
この1から4のフォルダのapple1,apple2,apple3,apple4のファイルをとりだし、それぞれのA1～A10セルを新たなファイルに自動転記する（apple1はA1～A10,apple2はＢ10～B10・・・）といった具合のマクロを組みたいと思っています。

あるフォルダの中のexcelファイルであれば、以下のソースコードを用いてコピーしたいファイルを選択してセルを転記しているのですが、今回のように、ディレクトリがいくつもあり、その各ディレクトリ中のファイル名の共通項を検索してそのセルを転記する方法が全く分かりません。
どなたかわかる方アドバイスをお願いします。
Sub ブック保存()
Dim j As Integer
Dim ファイル一覧 As Variant
ファイル名一覧 = Application.GetOpenFilename("apple,*.xlsm", MultiSelect:=True)
If VarType(ファイル名一覧) = vbBoolean Then Exit Sub
Application.EnableEvents = False
For i = 1 To UBound(ファイル名一覧)
Set ブック = Workbooks.Open(ファイル名一覧(i))
With ThisWorkbook.Worksheets(1)
For j = 1 To 10
.Cells(j, i) = ブック.Worksheets(1).Cells(j, 1).Value
Next

End With
ブック.Close
Next
Application.EnableEvents = True
End Sub

回答No.1

fmxBeem

このページが参考になると思います。
http://officetanaka.net/excel/vba/tips/tips36.htm

補足

ありがとうございます。
そのページのディレクトリ下のフォルダすべてを表示するプログラム
「
Sub Sample()
Call FileSearch("C:\Sample")
End Sub

Sub FileSearch(Path As String)
Dim FSO As Object, Folder As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Folder In FSO.GetFolder(Path).SubFolders
Debug.Print Folder.Path
Call FileSearch(Folder.Path) ''見つかったフォルダを引数に指定して、自分自身を呼び出す
Next Folder
End Sub
」におきまして、私はイミディエイトではなくて、それをセルに表示させるために、
「Sub Sample()
Call FileSearch("C:\Sample")
End Sub

Sub FileSearch(Path As String)
Dim FSO As Object, Folder As Variant
' Dim i As Integer
' i = 1
Set FSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To FSO.GetFolder(Path).SubFolders
Debug.Print Folder.Path
Call FileSearch(Folder.Path) ''見つかったフォルダを引数に指定して、自分自身を呼び出す
i = i + 1
Cells(i, 2) = Folder

Next i
End Sub
」
というプログラムを組んだのですが、２列目にはC:\Sample下のすべてのフォルダは表示されず、一部のものしか表示されません。
イミディエイトにはすべてのフォルダが表示されます。
何か間違っていたらご指摘よろしくお願いします。