循环遍历子文件夹及其子文件夹

Question

此脚本工作在子文件夹一级。

我想进入子文件夹，他们的子文件夹，和他们的子文件夹。我还想设置一个通配符，以便它只在名称有“预算”的情况下复制文件。

Sub Copy_files_this_works()
Dim FSO As Object, fld As Object
Dim fsoFile As Object
Dim fsoFol As Object

FromPath = "S:\SERVICE CHARGES 2018\" 
ToPath = "S:\SERVICE CHARGES 2018\Budget Upload\"  

Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.GetFolder(FromPath)

If FSO.FolderExists(fld) Then
    For Each fsoFol In FSO.GetFolder(FromPath).SubFolders
        For Each fsoFile In fsoFol.Files
            If Right(fsoFile, 4) = "xlsx" Then
                fsoFile.Copy ToPath
            End If
        Next
    Next
End If

End Sub

Answer 1

变更：

1. HostFolder -你想要循环的路径。
2. 确保有Sheet1 -详细信息将被导出的地方。
3. 粘贴两个Subs并运行"Main_Process“

尝试：

Option Explicit

Sub Main_Process()

    Dim FileSystem As Object
    Dim HostFolder As String
    Dim LRC As Long

    HostFolder = "C:\Users\XXXX\Desktop\Test\"

    With ThisWorkbook.Worksheets("Sheet1")

        LRC = .Cells(.Rows.Count, "A").End(xlUp).Row

        .Range("A2:F" & LRC).Clear

    End With

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.getFolder(HostFolder)

End Sub

Sub DoFolder(Folder)

    Dim SubFolder
    Dim File
    Dim LR As Long

    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next

    For Each File In Folder.Files

        With ThisWorkbook.Worksheets("Sheet1")

            LR = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Cells(LR + 1, 1).Value = File.Name
            .Cells(LR + 1, 2).Value = File.DateCreated
            .Cells(LR + 1, 3).Value = File.DateLastAccessed
            .Cells(LR + 1, 4).Value = File.DateLastModified
            .Cells(LR + 1, 5).Value = File.Type
            .Cells(LR + 1, 6).Value = File.Path

            .Cells(1, 1).Value = "Date"
            .Cells(1, 2).Value = Date

        End With

    Next

    ThisWorkbook.Worksheets("Sheet1").UsedRange.Columns.AutoFit

End Sub

Answer 2

您需要使用递归循环。有很多方法可以做到这一点。这是一个。

Option Explicit

Sub CreateList()
    Application.ScreenUpdating = False
    Workbooks.Add ' create a new workbook for the folder list
     ' add headers
    With Cells(1, 1)
        .Value = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    Cells(3, 1).Value = "Folder Path:"
    Cells(3, 2).Value = "Folder Name:"
    Cells(3, 3).Value = "Size:"
    Cells(3, 4).Value = "Subfolders:"
    Cells(3, 5).Value = "Files:"
    Cells(3, 6).Value = "Short Name:"
    Cells(3, 7).Value = "Short Path:"
    Range("A3:G3").Font.Bold = True
    ListFolders BrowseFolder, True
    Application.ScreenUpdating = True
End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
     ' lists information about the folders in SourceFolder
    Dim FSO    As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
    Dim r      As Long
    Set FSO = New Scripting.FileSystemObject
    Set SourceFolder = FSO.GetFolder(SourceFolderName)
     ' display folder properties
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    Cells(r, 1).Value = SourceFolder.Path
    Cells(r, 2).Value = SourceFolder.Name
    Cells(r, 3).Value = SourceFolder.Size
    Cells(r, 4).Value = SourceFolder.SubFolders.Count
    Cells(r, 5).Value = SourceFolder.Files.Count
    Cells(r, 6).Value = SourceFolder.ShortName
    Cells(r, 7).Value = SourceFolder.ShortPath
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFolders SubFolder.Path, True
        Next SubFolder
        Set SubFolder = Nothing
    End If
    Columns("A:G").AutoFit
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True

End Sub

Answer 3

下面是另一个递归dir函数，以防另一个函数对您不起作用：

Public Sub RecursiveDir(ByVal CurrDir As String)
    Dim Dirs() As String
    Dim NumDirs As Long
    Dim FileName As String
    Dim PathAndName As String
    Dim i As Long
    Dim Filesize As Double

'   Make sure path ends in backslash
    If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"

'   Put column headings on active sheet
    Cells(1, 1) = "Path"
    Cells(1, 2) = "Filename"
    Range("A1:D1").Font.Bold = True

'   Get files
    On Error Resume Next
    FileName = Dir(CurrDir & "*.*", vbDirectory)
    Do While Len(FileName) <> 0
      If Left(FileName, 1) <> "." Then 'Current dir
        PathAndName = CurrDir & FileName
        If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
          'store found directories
           ReDim Preserve Dirs(0 To NumDirs) As String
           Dirs(NumDirs) = PathAndName
           NumDirs = NumDirs + 1
        Else
          'Write the path and file to the sheet
          Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir
          Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileName
        End If
    End If
        FileName = Dir()
    Loop
    ' Process the found directories, recursively
    For i = 0 To NumDirs - 1
        RecursiveDir Dirs(i)
    Next i
End Sub