Retrieving filenames from a folder
2011-10-29 Files & Folders 0 407
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 SubThe 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