The following code will get every XLS file in every subdirectory starting at
c:\temp. Change as necessary. It will return cell B2 from the active
worksheet in each of the files. if a diffferent sheet is needed then the
code need a small modification.
Sub findfile()
'set MyFilename and strfold as required
RowCount = 1
'directory to start searching
strFolder = "c:\temp"
Application.EnableEvents = False
file_loc = ""
Set fso = CreateObject _
("Scripting.FileSystemObject")
Set folder = _
fso.GetFolder(strFolder)
Call GetWorksheetsSubFolder(strFolder + "\", _
MyFileName, file_loc, RowCount)
Application.EnableEvents = True
End Sub
Sub GetWorksheetsSubFolder(strFolder, MyFileName, ByRef file_loc, ByRef
RowCount)
Set fso = CreateObject _
("Scripting.FileSystemObject")
Set folder = _
fso.GetFolder(strFolder)
If folder.subfolders.Count > 0 Then
For Each sf In folder.subfolders
On Error GoTo 100
Call GetWorksheetsSubFolder(strFolder + sf.Name + "\", _
MyFileName, file_loc, RowCount)
100 Next sf
End If
'folder size in bytes
On Error GoTo 200
For Each fl In folder.Files
If UCase(Right(fl.Name, 4)) = ".XLS" Then
Workbooks.Open Filename:=fl
Set newbk = ActiveWorkbook
With ThisWorkbook.Sheets("Sheet1")
.Range("A" & RowCount) = newbk.ActiveSheet.Range("B2")
.Range("B" & RowCount) = fl.Name
.Range("C" & RowCount) = folder.Path
RowCount = RowCount + 1
End With
newbk.Close savechanges:=False
End If
Next fl
200 On Error GoTo 0
End Sub