Question

我从以前的各种文章中整理了很多代码（感谢大家！），我几乎有一个可行的解决方案。我想发生的是：

用户选择一个文件夹
在该文件夹中创建一个新文件夹，并将一些.dwg文件移到该文件夹中
然后，代码深入到下一个文件夹并执行相同的操作。

我的问题是代码正在深入到新创建的文件夹中，并且创建和循环不断。有没有一种方法可以跳过我刚刚创建的文件夹？该文件夹始终被命名为“原始DWG 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 \ MattsData \ New文件夹\ E2000电路图\ 85100004电气电路**存档** \原始DWG 23-09-19 \原始DWG 23-09-19 \原始DWG 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

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

1 个答案: