Thursday, July 1, 2010

Excel VBA : Loop through all the files and subfolders in a Folder

Hi All,

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:

radhika said...

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

Radhika said...

Can you please suggest some code lines in it..This is a bit urgently required.. I have to make this code Excel 2007 compatible..

Office Coder said...

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