I write this function many many times in my projects. When we have to create a temporary folder which are specific to our application, then I normally have to loop through all the files in a folder and put some validations so that my code should not replace any previous temp or log files. So I thought to share a small snippet of Excel VBA code where I am trying to search all the files in a Folder ( and its subfolders too) and printing in an Excel Worksheet.
Private fileCounter As Integer
Private activeSht As Worksheet
'Display all the files in a folder. Searches all the sub folders.
'Prints Folder Names in Column A and and the file Names in Column B
Sub SearchFiles()
Dim pth As String
Dim fso As FileSystemObject
Dim baseFolder As Folder
pth = "C:\Projects\" 'the base path which has to be searched for Files
Set fso = New FileSystemObject
''check if the folder actually exists or not
If (Not (fso.FolderExists(pth))) Then
'the folder path is invalid. Exiting.
MsgBox "Invalid Path"
Exit Sub
End If
Set baseFolder = fso.GetFolder(pth)
fileCounter = 1
Set activeSht = ActiveSheet
activeSht.Range("A1").Value = "Folder Name"
activeSht.Range("B1").Value = "File Name"
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
PrintFileNames baseFolder
ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub PrintFileNames(baseFolder As Folder)
Dim folder_ As Folder
Dim file_ As File
For Each folder_ In baseFolder.SubFolders
'call recursive function.
PrintFileNames folder_
Next folder_
For Each file_ In baseFolder.Files
'print files here
activeSht.Range("A1").Offset(fileCounter, 0).Value = baseFolder.Path
activeSht.Range("B1").Offset(fileCounter, 0).Value = file_.Name
fileCounter = fileCounter + 1
Next file_
End Sub
The above code loops through all the subfolders and the files in a given folder and prints the folder names in Column A and the file Names in Column B.
HTH,
Vikas
3 comments:
Hi..Your blog is quite useful for new developers..
You must be ware of filesearch method which was in VBA 2003 but not present in 2007.I am migrating this application as it is not Excel 2007 compatible:
Can you help me out with the following code:
Excel 2007 gets stuck on .filesearch method...
With Application.FileSearch
.NewSearch
.LookIn = "C:\FSB Reporting\Delta Renewal Bounty"
.SearchSubFolders = False
.fileName = "*.xls"
.Execute
If .FoundFiles.Count < 1 Then
MsgBox ("Please keep the dealsheets in the folder")
Exit Sub
End If
For i = 1 To .FoundFiles.Count
x = i + 82
Set wb = Workbooks.Open(fileName:=.FoundFiles(i), UpdateLinks:=False, ReadOnly:=True)
nameLength = Len(.FoundFiles(i))
b = nameLength - InStrRev(.FoundFiles(i), "\")
fileName = Mid(.FoundFiles(i), InStrRev(.FoundFiles(i), "\") + 1, b + 1)
Thanks a lot..
Radhika
Can you please suggest some code lines in it..This is a bit urgently required.. I have to make this code Excel 2007 compatible..
I would have used following code:
Private fileCounter As Integer
Sub SearchFiles()
Dim pth As String
Dim fso As FileSystemObject
Dim baseFolder As Folder
fileCounter = 0
pth = "C:\Projects\API\" 'the base path which has to be searched for Files
Set fso = New FileSystemObject
''check if the folder actually exists or not
If (Not (fso.FolderExists(pth))) Then
'the folder path is invalid. Exiting.
MsgBox "Invalid Path"
Exit Sub
End If
Set baseFolder = fso.GetFolder(pth)
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
PrintFileNames baseFolder, True
ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub PrintFileNames(baseFolder As Folder, searchSubFolders As Boolean)
Dim folder_ As Folder
Dim file_ As File
If (searchSubFolders) Then
For Each folder_ In baseFolder.SubFolders
'call recursive function.
PrintFileNames folder_, searchSubFolders
Next folder_
End If
For Each file_ In baseFolder.Files
'print files here
If (IsValidExtension(FindExtension(file_.Name))) Then
OpenFile file_
End If
Next file_
End Sub
Private Function IsValidExtension(extension As String) As Boolean
Dim extnValid As Boolean
If (UCase(extension) = "XLS" _
Or UCase(extension) = "XLSX" _
Or UCase(extension) = "XLTX" _
Or UCase(extension) = "XLTM" _
Or UCase(extension) = "XLSM" _
) Then
extnValid = True
End If
IsValidExtension = extnValid
End Function
Private Function FindExtension(fileName As String) As String
Dim extn As String
Dim lastIndex As Integer
Dim indxCounter As Integer
Dim char_ As String
For indxCounter = Len(fileName) To 1 Step -1
char_ = Mid(fileName, indxCounter, 1)
If (char_ = ".") Then
lastIndex = indxCounter
Exit For
End If
Next indxCounter
If (lastIndex > 0) Then
extn = Mid(fileName, lastIndex + 1, Len(fileName) - lastIndex)
End If
FindExtension = extn
End Function
Sub OpenFile(file_ As File)
Dim shortFileName As String
Dim wb As Workbook
Set wb = Workbooks.Open(file_.Path)
shortFileName = file_.Name
End Sub
Thanks,
Vikas
Post a Comment