Skip to content

Instantly share code, notes, and snippets.

@wizard04wsu
Last active April 1, 2017 17:25
Show Gist options
  • Save wizard04wsu/50652ba20f4163ca774e62717d06e945 to your computer and use it in GitHub Desktop.
Save wizard04wsu/50652ba20f4163ca774e62717d06e945 to your computer and use it in GitHub Desktop.
VBA functions for traversing files and folders and prompting the user to select a file/folder. Includes an example.
Private progress As Integer, progressFileCount As Integer
'start here
Sub doStuff()
Dim path As String
'get the path to the folder containing all the files
MsgBox "Select the folder containing all the files."
path = GetFolderName
If path = "" Then 'user clicked Cancel
Exit Sub
End If
progressFileCount = GetFileCount(path)
progress = 0
Application.ScreenUpdating = False 'so you don't see each file opening and closing
Application.DisplayStatusBar = True 'show the status bar at the bottom of the window
processFolder path
Application.StatusBar = False 'clear the status bar
Application.ScreenUpdating = True
End Sub
Private Sub processFile(wb as Workbook, filename as String)
'the `wb` parameter references the workbook
'...
End Sub
Private Sub processFolder(thePath)
Dim wb As Workbook
Dim theFile As String
Dim theDir As String
Dim sDirList As String: sDirList = ""
Dim arDirList() As String
Dim i As Integer: i = 1
If thePath <> "" Then
On Error Resume Next
ChangeDirectory thePath
If Err > 0 Then 'not a folder (just a file with no extension)
Exit Sub 'skip it
End If
On Error GoTo 0
theFile = Dir("*.xls*")
Do While theFile <> "" 'for each workbook in this folder
Set wb = Workbooks.Open(thePath & "\" & theFile)
processFile wb, theFile 'process the file
wb.Close
Call updateProgress 'update the progress in the status bar
theFile = Dir
Loop
theDir = Dir("*.", vbDirectory) 'subdirectories
Do While theDir <> "" 'for each subdirectory
If theDir <> "." And theDir <> ".." Then sDirList = sDirList & ";" & theDir 'save the directory name
theDir = Dir
Loop
arDirList = Split(sDirList, ";") 'convert the directory name list to an array
Do While i <= UBound(arDirList) 'for each subdirectory
processFolder (thePath & "\" & arDirList(i)) 'process the files & directories in that folder
i = i + 1
Loop
End If
End Sub
'counts the number of Excel files in a folder and its subfolders
Private Function GetFileCount(thePath)
Dim theFile As String
Dim theDir As String
Dim sDirList As String: sDirList = ""
Dim arDirList() As String
Dim i As Integer: i = 1
GetFileCount = 0
If thePath <> "" Then
On Error Resume Next
ChangeDirectory thePath
If Err > 0 Then 'not a folder (just a file with no extension)
Exit Function 'skip it
End If
On Error GoTo 0
theFile = Dir("*.xls*")
Do While theFile <> "" 'for each workbook in this folder
GetFileCount = GetFileCount + 1
theFile = Dir
Loop
theDir = Dir("*.", vbDirectory)
Do While theDir <> "" 'for each subdirectory
If theDir <> "." And theDir <> ".." Then sDirList = sDirList & ";" & theDir 'add it to the list
theDir = Dir
Loop
arDirList = Split(sDirList, ";") 'convert the subdirectory list to an array
Do While i <= UBound(arDirList) 'for each subdirectory
GetFileCount = GetFileCount + GetFileCount(thePath & "\" & arDirList(i)) 'recurse
i = i + 1
Loop
End If
End Function
Private Sub updateProgress()
progress = progress + 1
Application.StatusBar = "Processing files... " & Round(100 * progress / progressFileCount) & "% complete."
End Sub
'requires reference to Microsoft Office 14.0 Object Library
'prompts the user for a folder
'see http://www.vbaexpress.com/kb/getarticle.php?kb_id=896
Private Function GetFolderName(Optional OpenAt As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = OpenAt
.Show
If .SelectedItems.Count = 0 Then Exit Function
GetFolderName = .SelectedItems(1)
End With
End Function
'prompts the user for a file
Private Function GetFileName(Optional OpenAt As String) As String
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = OpenAt
.Show
If .SelectedItems.Count = 0 Then Exit Function
GetFileName = .SelectedItems(1)
End With
End Function
'changes the current directory to the specified path
'see https://www.mrexcel.com/forum/excel-questions/70668-help-chdir-please.html#post338674
Private Sub ChangeDirectory(path)
Dim oFS As Object
On Error Resume Next
ChDir path
If Err > 0 Then
On Error GoTo 0
Set oFS = CreateObject("Scripting.FileSystemObject")
ChDrive oFS.GetDriveName(path)
ChDir path
Set oFS = Nothing
End If
On Error GoTo 0
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment