Retrieving filenames from a folder
2011-10-29 Files & Folders 0 455
Sometimes you don't need to ask the user to select a list of files that you want to do something with. If you already know the source folder and types of files you want to retrieve you can use the function below. This function is also a simple replacement for the Application.FileSearch that is not longer supported by Excel.
Function GetFilesFromFolder(ByVal FolderPath As String, ByVal FileFilter As String) As Collection
' returns a collection of filenames from a folder where the filenames matches the file filter
' the returned filenames will probably not be in alphabetical order
Dim strFile As String
If Len(FolderPath) < 3 Then Exit Function
If Right(FolderPath, 1) <> Application.PathSeparator Then
FolderPath = FolderPath & Application.PathSeparator
End If
If Len(FileFilter) < 3 Then FileFilter = "*.*"
Set GetFilesFromFolder = New Collection
On Error Resume Next
strFile = Dir(FolderPath & FileFilter) ' first matching file in folder
On Error GoTo 0
Do While Len(strFile) > 0
GetFilesFromFolder.Add FolderPath & strFile
strFile = Dir ' next matching file in folder
Loop
If GetFilesFromFolder.Count = 0 Then Set GetFilesFromFolder = Nothing
End Function
Sub TestGetFilesFromFolder()
Dim coll As Collection, r As Long
Set coll = GetFilesFromFolder("C:\FolderName", "*.*")
If coll Is Nothing Then Exit Sub
Application.StatusBar = "Listing result, " & coll.Count & " files..."
Workbooks.Add
For r = 1 To coll.Count
Range("A" & r).Formula = coll(r)
Next r
Set coll = Nothing
Application.StatusBar = False
End Sub
The function above is somewhat limited since it does not support retrieving filenames from subfolders, and the filenames returned are probably not in alphabetical order.
If you want this type of functionality you can use the macros below.
Function FileSearch(ByVal InitialFolder As String, ByVal FileFilter As String, Optional InclSubFolders As Boolean = False) As Variant
' returns an array with filenames from FolderPath where the filenames matches FileFilter
' can include subfolders too
Dim coll As Collection
FileSearch = False
GetFolderFiles coll, InitialFolder, FileFilter, InclSubFolders
If Not coll Is Nothing Then
Application.StatusBar = "Sorting file search result, " & coll.Count & " files..."
FileSearch = Coll2Array(coll, True)
Application.StatusBar = False
End If
End Function
Sub GetFolderFiles(ByRef coll As Collection, ByVal FolderPath As String, ByVal FileFilter As String, Optional InclSubFolders As Boolean = False)
' adds filenames to coll from FolderPath where the filenames matches FileFilter
' can include subfolders too
Dim fso As Scripting.FileSystemObject, objFolder As Scripting.Folder, objSubFolder As Scripting.Folder, objFile As Scripting.File
If Len(FolderPath) < 3 Then FolderPath = CurDir
If Right(FolderPath, 1) <> Application.PathSeparator Then
FolderPath = FolderPath & Application.PathSeparator
End If
If Len(FileFilter) < 3 Then FileFilter = "*.*" ' all files
FileFilter = LCase(FileFilter) ' not case sensitive name compare
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFolder = fso.GetFolder(FolderPath)
On Error GoTo 0
If Not objFolder Is Nothing Then
If InclSubFolders Then
For Each objSubFolder In objFolder.SubFolders
GetFolderFiles coll, objSubFolder.Path, FileFilter, True
Next objSubFolder
Set objSubFolder = Nothing
End If
Application.StatusBar = "Searching for files: " & objFolder.Path & Application.PathSeparator & FileFilter
If coll Is Nothing Then Set coll = New Collection
For Each objFile In objFolder.Files
If LCase(objFile.Name) Like FileFilter Then ' not case sensitive name compare
coll.Add objFile.Path
End If
Next objFile
Set objFile = Nothing
End If
Set fso = Nothing
Application.StatusBar = False
If coll.Count = 0 Then Set coll = Nothing
End Sub
Function Coll2Array(coll As Collection, Optional blnSort As Boolean = False, Optional blnBinaryCompare As Boolean = False) As Variant
Dim arrItems() As String, i As Long, j As Long, strTemp As String
Coll2Array = False
If coll Is Nothing Then Exit Function
If coll.Count = 0 Then Exit Function
ReDim arrItems(0 To coll.Count - 1)
For i = 1 To coll.Count
arrItems(i - 1) = coll(i)
Next i
If blnSort And coll.Count > 1 Then
For i = LBound(arrItems) To UBound(arrItems) - 1
For j = i + 1 To UBound(arrItems)
If blnBinaryCompare Then
If arrItems(i) > arrItems(j) Then
strTemp = arrItems(i)
arrItems(i) = arrItems(j)
arrItems(j) = strTemp
End If
Else ' not case sensitive comparare
If LCase(arrItems(i)) > LCase(arrItems(j)) Then
strTemp = arrItems(i)
arrItems(i) = arrItems(j)
arrItems(j) = strTemp
End If
End If
Next j
Next i
End If
Coll2Array = arrItems
End Function
Sub TestFileSearch()
Dim varItems As Variant, i As Long, r As Long
varItems = FileSearch("C:\FolderName", "*.*", True)
If Not IsArray(varItems) Then Exit Sub
Application.StatusBar = "Listing result, " & UBound(varItems) + 1 & " files..."
Workbooks.Add
r = 0
For i = LBound(varItems) To UBound(varItems)
r = r + 1
Range("A" & r).Formula = varItems(i)
Next i
Erase varItems
Application.StatusBar = False
End Sub