Search Directories to List Files VBA

[Admin]

Hi All,

Here is a method to list files from a directory (Including sub directory). I hope you would find this useful.


Function SearchFiles(ByVal FolderToSearch As String, Optional ByVal Extn As String = "xls", _
Optional ByVal SearchSubFolders As Boolean = False)


'//Developed by : ExcelFox.com

If Right$(FolderToSearch, 1) <> "\" Then FolderToSearch = FolderToSearch & "\"
If Not CBool(Len(Dir(FolderToSearch, vbDirectory))) Then Exit Function

Dim objFSO As Object
Dim objItem As Object
Dim objFldr As Object
Dim objFolder As Object
Dim FilesList() As String
Dim CountFiles As Long
Dim strFileName As String

If Left$(Extn, 1) <> "." Then Extn = "." & Extn
Extn = Replace(Extn, "*", "")
Select Case SearchSubFolders
Case True
Set objFSO = CreateObject("scripting.filesystemobject")
Set objFolder = objFSO.getfolder(FolderToSearch)

For Each objItem In objFolder.Files
If InStr(1, LCase$(Mid$(objItem.Name, InStrRev(objItem.Name, "."))), LCase$(Extn)) Then
CountFiles = CountFiles + 1
ReDim Preserve FilesList(CountFiles)
FilesList(CountFiles) = objItem
End If
Next
If objFolder.subfolders.Count Then
For Each objFldr In objFolder.subfolders
For Each objItem In objFldr.Files
If InStr(1, LCase$(Mid$(objItem.Name, InStrRev(objItem.Name, "."))), LCase$(Extn)) Then
CountFiles = CountFiles + 1
ReDim Preserve FilesList(CountFiles)
FilesList(CountFiles) = objItem
End If
Next
Next
End If
If CountFiles Then SearchFiles = FilesList
Case False
strFileName = Dir(FolderToSearch & "*" & Extn)
Do While Len(strFileName)
CountFiles = CountFiles + 1
ReDim Preserve FilesList(CountFiles)
FilesList(CountFiles) = FolderToSearch & strFileName
strFileName = Dir()
Loop
If CountFiles Then SearchFiles = FilesList
End Select

Set objFldr = Nothing
Set objFolder = Nothing
Set objFSO = Nothing

End Function

and call the function like..


Sub kTest()
Dim a
a = SearchFiles("C:\MyFolder\", ".xls*", 1)
MsgBox Join(a, vbLf)
End Sub

[Rasm]

You can also use the filedialog method.



Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function



where

FileSpec = TextfilePath.Text & "\*.XLS"



Function GetFileList(FileSpec As String, FileArray() As Variant) As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function

[Admin]

Thanks Rasm

[Jimmyc]

I am just learning vba; I am using Excel 2010 with Win7 Professional. I copied the code in the first Admin post to two modules--but when I run the code (call the function) I get a compile error--"invalid outside procedure" on the FoldertoSearch in the first line of the code. Thanks. JimC