VBA中怎么遍历所选路径中所有文件夹及其子文件夹(多个子文件)，并返回所有的最底层的文件夹路径

Posted 2023-03-19

选择一个路径后，返回所有文件夹中的子文件夹及其子文件夹，也就是每个最下层的文件夹路径。文件夹层数没规律，新手，求解，谢谢各位了

答：执行"获取所有文件夹"，按提示操作。文件夹清单会显示在工作表的AB列中。

Sub 获取所有文件夹()
    Dim Directory As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\\"
        .Title = "请选择一个文件夹"
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        Else
            Directory = .SelectedItems(1)
        End If
    End With
    Cells.ClearContents
    Call RecursiveDir(Directory)
End Sub
Public Sub RecursiveDir(ByVal CurrDir As String)
    Dim Dirs() As String
    Dim NumDirs As Long
    Dim Filesize As Double
    Dim TotalFolders, SingleFolder
    Cells(1, 1) = "目录名"
    Cells(1, 2) = "日期/时间"
    Range("A1:B1").Font.Bold = True
    
    Set TotalFolders = CreateObject("Scripting.FileSystemObject").GetFolder(CurrDir).SubFolders
    Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir
    Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileDateTime(CurrDir)
    If TotalFolders.Count <> 0 Then
        For Each SingleFolder In TotalFolders
            ReDim Preserve Dirs(0 To NumDirs) As String
            Dirs(NumDirs) = SingleFolder
            NumDirs = NumDirs + 1
        Next
    End If
    For i = 0 To NumDirs - 1
        RecursiveDir Dirs(i)
    Next i
End Sub

参考技术A Sub Test()
    Dim MyName, Dic, Did, I, T, F, TT, MyFileName
    T = Time
    Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add ("C:\\Users\\Administrator\\Desktop\\VB.NET\\"), ""
    I = 0
    Do While I < Dic.Count
        Ke = Dic.keys   '开始遍历字典
        MyName = Dir(Ke(I), vbDirectory)    '查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
                    Dic.Add (Ke(I) & MyName & "\\"), ""  '就往字典中添加这个次级目录名作为一个条目
                End If
            End If
            MyName = Dir    '继续遍历寻找
        Loop
        I = I + 1
    Loop
    Did.Add ("文件清单"), ""    '以查找D盘My Documents下所有EXCEL文件为例
    For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.*")
        Do While MyFileName <> ""
            Did.Add (Ke & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    For Each Sh In ThisWorkbook.Worksheets
        If Sh.Name = "XLS文件清单" Then
            Sheets("XLS文件清单").Cells.Delete
            F = True
            Exit For
        Else
            F = False
        End If
    Next
    If Not F Then
        Sheets.Add.Name = "XLS文件清单"
    End If
    Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
    TT = Time - T
    MsgBox Minute(TT) & "分" & Second(TT) & "秒"
End Sub

VBA获取某文件夹下所有文件和子文件目录的文件

参考技术A 【引用位置】 https://blog.csdn.net/pashine/article/details/42100237

'-------------------------------------------
'获取某文件夹下的所有Excel文件
'-------------------------------------------
Sub getExcelFile(sFolderPath As String)
On Error Resume Next
Dim f As String
Dim file() As String
Dim x
k = 1

ReDim file(1)
file(1) = sFolderPath & ""

End Sub

'-------------------------------------------
'获取某文件夹下的所有文件和子目录下的文件
'-------------------------------------------
Sub getAllFile(sFolderPath As String)
'Columns(1).Delete
On Error Resume Next
Dim f As String
Dim file() As String
Dim i, k, x
x = 1
i = 1
k = 1

ReDim file(1 To i)
file(1) = sFolderPath & ""

'-- 获得所有子目录
Do Until i > k
f = Dir(file(i), vbDirectory)
Do Until f = ""
If InStr(f, ".") = 0 Then
k = k + 1
ReDim Preserve file(1 To k)
file(k) = file(i) & f & ""
End If
f = Dir
Loop
i = i + 1
Loop

'-- 获得所有子目录下的所有文件
For i = 1 To k
f = Dir(file(i) & " . ") '通配符 . 表示所有文件，*.xlsx Excel文件
Do Until f = ""
'Range("a" & x) = f
Range("a" & x).Hyperlinks.Add Anchor:=Range("a" & x), Address:=file(i) & f, TextToDisplay:=f
x = x + 1
f = Dir
Loop
Next
End Sub