三重循环删除空文件夹

Question

我试图通过三重循环删除那些空的文件夹。

订单是：  1.进入主文件夹。  2.检查第一个遇到的文件夹  3.检查主文件夹的第一个子文件夹。  4.如果该子文件夹包含另一个文件夹，请输入此subSubFolder  5.如果它是最后一个文件夹并且不包含任何内容，程序将删除它。  5.1如果文件夹中包含某些内容（文件，excel，pdf，无关紧要），请转到下一个subSubFolder。  6.继续，直到没有空文件夹。

基本上，代码必须保持不包含文件的文件夹。

但我不知道为什么代码不会继续，只是在不删除空代码的情况下停止。

这是文件夹结构： Folder Path

这是我使用的代码。：

Sub recursiveDeleting()
    Dim sFldr As Object
    Dim ssFldr As Object
    Dim sssFldr As Object
    Dim fs

    Set fs = CreateObject("Scripting.FileSystemObject")
    sFound = False
    ssFound = False
    sssFound = False

    flPath = ActiveWorkbook.Path & "\"
    YearPath = flPath & "2017\"
    FARFIpath = YearPath & "\FAR_FI\"

    For Each sFldr In CreateObject("Scripting.FileSystemobject").GetFolder(FARFIpath).SubFolders
        For Each ssFldr In CreateObject("Scripting.FileSystemobject").GetFolder(sFldr).SubFolders
            For Each sssFldr In CreateObject("Scripting.FileSystemobject").GetFolder(ssFldr).SubFolders
                If Dir(sssFldr & "\*.*") = "" Then
                    RmDir (sssFldr)
                Else
                    sssFound = True
                End If

                If sssFound = True Then
                    Exit For
                End If
            Next sssFldr

        If fs.FolderExists(ssFldr) = "" Then
            RmDir (ssFldr)
        Else
            ssFound = True
        End If
        If ssFound = True Then
            Exit For
        End If
        Next ssFldr
    If Dir(sFldr, vbDirectory) = "" Then
        RmDir (sFldr)
        sFound = True
    End If

   If sFound = True Then
      Exit For
   End If
 Next sFldr
End Sub

感谢您的时间，祝您有个美好的一天！

Answer 1

尝试下面的代码，经过测试工作（如果它之后是空的，它也将删除根文件夹。如果要跟踪递归代码，可以介意写博客。

示例 - 仅突出显示文件夹中的空白文本文件（所有其他文件没有文件）

Option Explicit

Private oFSO As Object

Sub DeleteEmptyFolder()
    Dim oRootFDR As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oRootFDR = oFSO.GetFolder("C:\Test\mount") '<--- Change to your root folder
    If DeleteEmptyFolderOnly(oRootFDR) Then
        oRootFDR.Delete
    End If
    Set oRootFDR = Nothing
    Set oFSO = Nothing
End Sub

Private Function DeleteEmptyFolderOnly(ByRef oFDR As Object) As Boolean
    Dim bDeleteFolder As Boolean, oSubFDR As Object
    bDeleteFolder = False
    ' Recurse into SubFolders
    For Each oSubFDR In oFDR.SubFolders
        If DeleteEmptyFolderOnly(oSubFDR) Then
            Debug.Print "Delete", oSubFDR.Path ' Comment for production use
            oSubFDR.Delete
        End If
    Next
    ' Mark ok to delete when no files and subfolders
    If oFDR.Files.Count = 0 And oFDR.SubFolders.Count = 0 Then
        bDeleteFolder = True
    End If
    DeleteEmptyFolderOnly = bDeleteFolder
End Function

执行代码后，文件夹保留为：
并且即时窗口显示已删除的文件夹：