excel - 如何在循环浏览子文件夹时跳过新创建的文件夹？

Question

我从以前的各种帖子中拼凑了很多代码(感谢你们所有人!)，我几乎有了一个可行的解决方案。
我想要发生的是:

用户选择文件夹

在该文件夹内创建了一个新文件夹，并将一些 .dwg 文件移至其中

然后代码向下钻取到下一个文件夹并执行相同的操作。

我的问题是代码正在深入到新创建的文件夹中并创建无限循环。有没有办法跳过我刚刚创建的文件夹？该文件夹始终命名为“Original DWGs DD-mm-yy”，所以我正在考虑添加

If InStr(FromPath, "original") = 0 Then
Exit Sub
End If

但我不认为“退出子”是在 fso 循环中做的正确的事情？

Option Explicit
Dim sFolder As String

Sub CommandButton1_Click()

    ' Open the select folder prompt
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            sFolder = .SelectedItems(1)
        End If
    End With

    If sFolder <> "" Then ' if a file was chosen
   Debug.Print sFolder
    End If

DrillDown

End Sub

Sub DrillDown()
    Dim FSO As Object 'FileSystemObject
    Dim fldStart As Object 'Folder
    Dim fld As Object 'Folder
    Dim fl As Object 'File
    Dim Mask As String

    Set FSO = CreateObject("scripting.FileSystemObject") ' late binding

    Set fldStart = FSO.GetFolder(sFolder) ' <-- use your FileDialog code here

    Mask = "*.dwg"
       For Each fld In fldStart.SubFolders
        ListFolders fld, Mask
    Next
End Sub


Sub ListFolders(fldStart As Object, Mask As String)
    Dim fld As Object 'Folder
    Dim FromPath As String

    For Each fld In fldStart.SubFolders
        Debug.Print fld.Path & "\"

'move all specified files from FromPath to ToPath.
'Note: It will create the folder ToPath for you
    Dim FSO As Object
    Dim ToPath As String
    Dim FileExt As String
    Dim FNames As String
    Dim diaFolder As FileDialog
    Dim selected As Boolean
    Dim FldCheck As String

    FromPath = fld.Path & "\"

    ToPath = FromPath & "Original DWGs " & Format(Date, "dd-mm-yy")  '<< Change only the destination folder

Debug.Print ToPath

    FileExt = "*.dwg"   '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        MsgBox "No .dwg files in " & FromPath
       'Exit Sub
       GoTo Err
         End If

    Set FSO = CreateObject("scripting.filesystemobject")


If FSO.FolderExists(ToPath) = False Then
        FSO.CreateFolder (ToPath)
End If

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath

Err:
    FileExt = "*.err"   '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        'MsgBox "No .err files in " & FromPath
        'Exit Sub
        GoTo Bak
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(ToPath) = False Then
   FSO.CreateFolder (ToPath)
End If

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath


    '---
Bak:
    FileExt = "*.bak"   '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        'MsgBox "No .bak files in " & FromPath
        'Exit Sub
        GoTo Log
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(ToPath) = False Then
   FSO.CreateFolder (ToPath)
End If

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath

    '---
Log:
    FileExt = "*.log"   '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        'MsgBox "No .log files in " & FromPath
        Exit Sub
        End If

    Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(ToPath) = False Then
   FSO.CreateFolder (ToPath)
End If

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath

    Set diaFolder = Nothing

        ListFolders fld, Mask
    Next

End Sub

我已经按照建议添加了代码。但是现在它循环并在前一个内部创建 6 个“原始 DWG”，并将文件移动到第 5 层。然后我得到一个找不到路径的错误？

代码运行后的文件路径:
C:\Users\d.holpin\Desktop\Matts Data\New 文件夹\E2000 Circuit Drawings\85100004 ELECTRICAL CIRCUIT**ARCHIVE**\Original DWGs 23-09-19\Original DWGs 23-09-19\Original DWGs 23- 09-19\原始 DWG 23-09-19**原始 DWG 23-09-19**\原始 DWG 23-09-19

文件已从存档移至倒数第二个原始 DWG(以粗体突出显示)

目前的代码是:

Option Explicit
Dim sFolder As String

Sub CommandButton1_Click()

    ' Open the select folder prompt
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then ' if OK is pressed
            sFolder = .SelectedItems(1)
        End If
    End With

    If sFolder <> "" Then ' if a file was chosen
   Debug.Print sFolder
    End If

DrillDown

End Sub

Sub DrillDown()
    Dim FSO As Object 'FileSystemObject
    Dim fldStart As Object 'Folder
    Dim fld As Object 'Folder
    Dim fl As Object 'File
    Dim Mask As String
    Dim test As String

    Set FSO = CreateObject("scripting.FileSystemObject") ' late binding

    Set fldStart = FSO.GetFolder(sFolder) ' <-- use your FileDialog code here

    Mask = "*.dwg"

    For Each fld In fldStart.SubFolders
    test = InStr(1, fld.Name, "Original DWGs ")
    Debug.Print test
    If InStr(1, fld.Name, "Original DWGs ") = 0 Then ListFolders fld, Mask

    Next

       'For Each fld In fldStart.SubFolders
        'ListFolders fld, Mask
    'Next
End Sub


Sub ListFolders(fldStart As Object, Mask As String)
    Dim fld As Object 'Folder
    Dim FromPath As String

    For Each fld In fldStart.SubFolders '2nd tme around it jump from here to the end if listfolders?

     Debug.Print fld.Path & "\"

'move all specified files from FromPath to ToPath.
'Note: It will create the folder ToPath for you
    Dim FSO As Object
    Dim ToPath As String
    Dim FileExt As String
    Dim FNames As String
    Dim diaFolder As FileDialog
    Dim selected As Boolean
    Dim FldCheck As String
FromPath = ""
    FromPath = fld.Path & "\"

    ToPath = FromPath & "Original DWGs " & Format(Date, "dd-mm-yy")  '<< Change only the destination folder

Debug.Print ToPath

    FileExt = "*.dwg"   '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        'MsgBox "No .dwg files in " & FromPath
       'Exit Sub
       GoTo Err
         End If

    Set FSO = CreateObject("scripting.filesystemobject")


If FSO.FolderExists(ToPath) = False Then
        FSO.CreateFolder (ToPath)
End If

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath

Err:
    FileExt = "*.err"   '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        'MsgBox "No .err files in " & FromPath
        'Exit Sub
        GoTo Bak
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(ToPath) = False Then
   FSO.CreateFolder (ToPath)
End If

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath


    '---
Bak:
    FileExt = "*.bak"   '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        'MsgBox "No .bak files in " & FromPath
        'Exit Sub
        GoTo Log
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(ToPath) = False Then
   FSO.CreateFolder (ToPath)
End If

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath

    '---
Log:
    FileExt = "*.log"   '<< Change

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    FNames = Dir(FromPath & FileExt)
    If Len(FNames) = 0 Then
        'MsgBox "No .log files in " & FromPath
        'Exit Sub
        GoTo FIN
        End If

    Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(ToPath) = False Then
   FSO.CreateFolder (ToPath)
End If

    FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
FIN:
    Set diaFolder = Nothing
    FromPath = ""

    ToPath = ""

        ListFolders fld, Mask
    Next

End Sub

Answer 1

在 DrillDown 中，您应该在循环子文件夹的位置添加您提到的检查:

For Each fld In fldStart.SubFolders
    If InStr(1, fld.Name, "Original DWGs ") = 0 Then ListFolders fld, Mask
Next