I would use more of Ron's code. The top two procedures came directly from Ron's
sample workbook (with no changes at all!).
http://www.rondebruin.nl/fso.htm
They were in the Basic_Code_Module.
The third procedure just retrieved the values from the activesheet. I wasn't
sure what you were doing in your code, so this is mostly just msgboxes:
Option Explicit
Private myFiles() As String
Private Fnum As Long
Function Get_File_Names(MyPath As String, Subfolders As Boolean, _
ExtStr As String, myReturnedFiles As Variant) As Long
Dim Fso_Obj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create FileSystemObject object
Set Fso_Obj = CreateObject("Scripting.FileSystemObject")
Erase myFiles()
Fnum = 0
'Test if the folder exist and set RootFolder
If Fso_Obj.FolderExists(MyPath) = False Then
Exit Function
End If
Set RootFolder = Fso_Obj.GetFolder(MyPath)
'Fill the array(myFiles)with the list of Excel files in the folder(s)
'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(file.Name) Like LCase(ExtStr) Then
Fnum = Fnum + 1
ReDim Preserve myFiles(1 To Fnum)
myFiles(Fnum) = MyPath & file.Name
End If
Next file
'Loop through the files in the Sub Folders if SubFolders = True
If Subfolders Then
Call ListFilesInSubfolders(OfFolder:=RootFolder, FileExt:=ExtStr)
End If
myReturnedFiles = myFiles
Get_File_Names = Fnum
End Function
Sub ListFilesInSubfolders(OfFolder As Object, FileExt As String)
'Origenal SubFolder code from Chip Pearson
'
http://www.cpearson.com/Excel/RecursionAndFSO.htm
'Changed by Ron de Bruin, 27-March-2008
Dim SubFolder As Object
Dim fileInSubfolder As Object
For Each SubFolder In OfFolder.Subfolders
ListFilesInSubfolders OfFolder:=SubFolder, FileExt:=FileExt
For Each fileInSubfolder In SubFolder.Files
If LCase(fileInSubfolder.Name) Like LCase(FileExt) Then
Fnum = Fnum + 1
ReDim Preserve myFiles(1 To Fnum)
myFiles(Fnum) = SubFolder & "\" & fileInSubfolder.Name
End If
Next fileInSubfolder
Next SubFolder
End Sub
Sub DoTheWork()
Dim sFol As String
Dim sPattern As String
Dim TotFiles As Long
Dim myFiles As Variant
Dim fCtr As Long
Dim wkbk As Workbook
With ActiveSheet
sFol = .Range("D1").Value
sPattern = "*" & .Range("B3").Value & "*.xls"
End With
TotFiles = Get_File_Names(MyPath:=sFol, _
Subfolders:=True, _
ExtStr:=sPattern, _
myReturnedFiles:=myFiles)
If TotFiles > 0 Then
For fCtr = LBound(myFiles) To UBound(myFiles)
Set wkbk = Nothing
On Error Resume Next
Set wkbk = Workbooks.Open(Filename:=myFiles(fCtr), ReadOnly:=True)
On Error GoTo 0
If wkbk Is Nothing Then
MsgBox myFiles(fCtr) & " wasn't opened"
Else
MsgBox fCtr & ". " & myFiles(fCtr)
wkbk.Close savechanges:=False
End If
Next fCtr
End If
End Sub
It kind of looked like you wanted to extract a partial name from the long file
name. If that's the case, remember that you can use instrrev() to find the
position of the last backslash.
