Excel VBA: Select multiple folders - vba

Question

I currently have a macro that checks a folder for excel files and runs a few formatting type adjustments (adds columns etc).
The problem is that it will only allow me to select one folder and check in there. There are lots of folders that I need it to check in which all exist within the same directory.
I cannot select more than one folder to check in, even by adjusting the AllowMultiSelect to True. How can I modify this code so that it will allow me to select all folders within a directory?
Sub Button1_Click()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
myExtension = "*.xls"
myFile = Dir(myPath & myExtension)
Do While myFile <> ""
Set wb = Workbooks.Open(fileName:=myPath & myFile)
DoEvents
'Formatting adjustments etc go here
wb.Close SaveChanges:=True
DoEvents
myFile = Dir
Loop
MsgBox "Complete."
End Sub

Answer 1

I think I come up with some better solution than manually selecting all the folders. You said that all of your files are in some directory, which have some subfolders inside. With below code, you will loop through every file in folder you pick. You will store every formating logics in Formatting sub.
Sub Button1_Click()
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Dim MyPath As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1)
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
Call GetAllFiles(MyPath, objFSO)
Call GetAllFolders(MyPath, objFSO)
MsgBox "Complete."
NextCode:
End Sub
Sub GetAllFiles(ByVal strPath As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objFile As Object
Set objFolder = objFSO.GetFolder(strPath)
For Each objFile In objFolder.Files
Formatting (objFile.Path)
Next objFile
End Sub
Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object)
Dim objFolder As Object
Dim objSubFolder As Object
Set objFolder = objFSO.GetFolder(strFolder)
For Each objSubFolder In objFolder.subfolders
Call GetAllFiles(objSubFolder.Path, objFSO)
Call GetAllFolders(objSubFolder.Path, objFSO)
Next objSubFolder
End Sub
Sub Formatting(strFile As String)
Dim wb As Workbook
If Right(strFile, 3) = "xls" Then
Set wb = Workbooks.Open(Filename:=MyPath & myFile)
DoEvents
'Formatting adjustments etc go here
wb.Close SaveChanges:=True
DoEvents
myFile = Dir
End If
End Sub

Answer 2

How about this concept? You recursively map to all files in all folders, and create a schema of your whole folder structure. Then, control each file, based on each folder path.
Option Explicit
Sub ListAllFiles()
searchForFiles "C:\your_path_here\", "writefilestosheet", "*.*", True, True
End Sub
Sub processOneFile(ByVal aFilename As String)
Debug.Print aFilename
End Sub
Sub writeFilesToSheet(ByVal aFilename As String)
With ActiveSheet
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = aFilename
End With
End Sub
Private Sub processFiles(ByVal DirToSearch As String, _
ByVal ProcToCall As String, _
ByVal FileTypeToFind As String)
Dim aFile As String
aFile = Dir(DirToSearch & FileTypeToFind)
Do While aFile <> ""
Application.Run ProcToCall, DirToSearch & aFile
aFile = Dir()
Loop
End Sub
Private Sub processSubFolders(ByVal DirToSearch As String, _
ByVal ProcToCall As String, _
ByVal FileTypeToFind As String, _
ByVal SearchSubDir As Boolean, _
ByVal FilesFirst As Boolean)
Dim aFolder As String, SubFolders() As String
ReDim SubFolders(0)
aFolder = Dir(DirToSearch, vbDirectory)
Do While aFolder <> ""
If aFolder <> "." And aFolder <> ".." Then
If (GetAttr(DirToSearch & aFolder) And vbDirectory) _
= vbDirectory Then
SubFolders(UBound(SubFolders)) = aFolder
ReDim Preserve SubFolders(UBound(SubFolders) + 1)
End If
End If
aFolder = Dir()
Loop
If UBound(SubFolders) <> LBound(SubFolders) Then
Dim i As Long
For i = LBound(SubFolders) To UBound(SubFolders) - 1
searchForFiles _
DirToSearch & SubFolders(i), _
ProcToCall, FileTypeToFind, SearchSubDir, FilesFirst
Next i
End If
End Sub
Sub searchForFiles(ByVal DirToSearch As String, ByVal ProcToCall As String, _
Optional ByVal FileTypeToFind As String = "*.*", _
Optional ByVal SearchSubDir As Boolean = False, _
Optional ByVal FilesFirst As Boolean = False)
On Error GoTo ErrXIT
If Right(DirToSearch, 1) <> Application.PathSeparator Then _
DirToSearch = DirToSearch & Application.PathSeparator
If FilesFirst Then processFiles DirToSearch, ProcToCall, FileTypeToFind
If SearchSubDir Then processSubFolders DirToSearch, ProcToCall, _
FileTypeToFind, SearchSubDir, FilesFirst
If Not FilesFirst Then _
processFiles DirToSearch, ProcToCall, FileTypeToFind
Exit Sub
ErrXIT:
MsgBox "Fatal error: " & Err.Description & " (Code=" & Err.Number & ")"
Exit Sub
End Sub