Empty Folder Search...Need to Add Deeper Folder Levels to VBA Coding

[Arkabama]

I am attempting to construct a macro to identify empty folders within a directory and have been somewhat successful. In the code below, I can run the macro and select a folder with a dialog box, and it creates a link in my spreadsheet starting in Cell A5. It will identify the subfolders in the object folder that do not contain files, but it only lists the subfolder, not any nested folders within. Does anyone have thoughts on how I can add code that will achieve this? Thank you fellow VBAers.

Sub ListEmptyFolders()

Dim xPath As String
Dim objFSO As Object
Dim objFolder As Object
Dim ObjSubFolder As Object
Dim i As Integer
Dim Folder As String
Dim FriendlyName As String
Dim CheckFolder As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next

xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(xPath)
i = 1
For Each ObjSubFolder In objFolder.SubFolders
If ObjSubFolder.Size = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 1), _ 'starts list in Cell A5
Address:=ObjSubFolder, _
TextToDisplay:=objFolder + ObjSubFolder.Name
CheckFolder = ObjSubFolder & ""
i = i + 1
End If
Next ObjSubFolder
End Sub

 

[Micron]

This is not something I do often (OK it is actually rare). Unless somebody feeds you code, what you want to look for is a recursive function. Such a procedure will drill down in a folder's subfolders until if finds no more. Then it will execute the next iteration one level up until it finds no more. Then it will execute the next iteration one level up ... until it gets back to the starting folder. If there are no more subfolders in the starting folder, the code is done. Otherwise it moves down one sub folder and sort of starts all over again.

Please post code tags (use vba button on posting toolbar) and paste between the resulting vba code tags.

 

[Arkabama]

Sub ListEmptyFolders()

Dim xPath As String
Dim objFSO As Object
Dim objFolder As Object
Dim ObjSubFolder As Object
Dim i As Integer
Dim Folder As String
Dim FriendlyName As String
Dim CheckFolder As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next

xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(xPath)
i = 1
For Each ObjSubFolder In objFolder.SubFolders
If ObjSubFolder.Size = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 1), _ 'starts list in Cell A5
Address:=ObjSubFolder, _
TextToDisplay:=objFolder + ObjSubFolder.Name
CheckFolder = ObjSubFolder & ""
i = i + 1
End If
Next ObjSubFolder
End Sub

 

[Arkabama]

Sub ListEmptyFolders()

Dim xPath As String
Dim objFSO As Object
Dim objFolder As Object
Dim ObjSubFolder As Object
Dim i As Integer
Dim Folder As String
Dim FriendlyName As String
Dim CheckFolder As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next

xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(xPath)
i = 1
For Each ObjSubFolder In objFolder.SubFolders
If ObjSubFolder.Size = 0 Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 1), _ 'starts list in Cell A5
Address:=ObjSubFolder, _
TextToDisplay:=objFolder + ObjSubFolder.Name
CheckFolder = ObjSubFolder & ""
i = i + 1
End If
Next ObjSubFolder
End Sub

Ok, figured the code tag out. Thanks for the tip.

 

[Micron]

Just need to work on your indentation now. Also see comment I added in code.

Sub ListEmptyFolders()
Dim xPath As String, Folder As String, FriendlyName As String, CheckFolder As String
Dim objFSO As Object, objFolder As Object, ObjSubFolder As Object
Dim i As Integer

With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Choose the folder"
    .Show
End With
On Error Resume Next '?? If err is raised in next line, it will be ignored. Could be an issue

xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(xPath)
i = 1
For Each ObjSubFolder In objFolder.SubFolders
    If ObjSubFolder.Size = 0 Then
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 1), _ 'starts list in Cell A5
        Address:=ObjSubFolder, _
        TextToDisplay:=objFolder + ObjSubFolder.Name
        CheckFolder = ObjSubFolder & ""
        i = i + 1
    End If
Next ObjSubFolder
    
End Sub