Last active
April 1, 2017 17:25
-
-
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.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'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