遍历文件夹下文件名 几种方法

获取文件夹中文件名称
Sub test()
Dim Mypath, MyName
Mypath = ThisWorkbook.Path & "\"    ' 指定路径。
MyName = Dir(Mypath, vbDirectory)   '
Do While MyName <> ""
    If MyName <> "." And MyName <> ".." Then
            Debug.Print MyName
    End If
    MyName = Dir
Loop
End Sub

获取文件名称,并注明路径:
Sub 所有文件夹下文件名A()
    Dim MyPath, MyName, MyFileName, dic, d, i&, arr
    Set dic = CreateObject("Scripting.Dictionary")
    Set d = CreateObject("Scripting.Dictionary")
    Application.DisplayAlerts = False
    MyPath = ThisWorkbook.Path & "\"
    dic.Add (MyPath), ""
    Do While i < dic.Count
        arr = dic.keys
        MyName = Dir(arr(i), vbDirectory)
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(arr(i) & MyName) And vbDirectory) = vbDirectory Then
                    dic.Add (arr(i) & MyName & "\"), ""
                End If
            End If
            MyName = Dir
        Loop
        i = i + 1
    Loop
    For Each arr In dic.keys
        MyFileName = Dir(arr & "*.xls")
        Do While MyFileName <> "" And MyFileName <> ThisWorkbook.Name
            d.Add (arr & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    For Each arr In dic.keys
        MyFileName = Dir(arr & "*.doc")
        Do While MyFileName <> "" And MyFileName <> ThisWorkbook.Name
            d.Add (arr & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
    Range("A2:Z65536").ClearContents
    [E2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    For i = 2 To Cells(65536, 5).End(3).Row
        arr = Split(Cells(i, 5), "\")
        Cells(i, 1) = arr(UBound(arr))
        Cells(i, 2) = arr(UBound(arr) - 3)
        Cells(i, 3) = arr(UBound(arr) - 2)
        Cells(i, 4) = arr(UBound(arr) - 1)
    Next
    Columns(5).ClearContents
    Application.DisplayAlerts = True
End Sub

取得指定路径下所有文件夹及文件名称:
Sub M_dir() '这是一个主模块，中间调用两个子模块，一个遍历指定目录下的所有文件夹，一个遍历文件夹下的所有EXCEL文件
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    On Error Resume Next
    Sheets.Add.Name = "路径"
    If Err.Number <> 0 Then
        ActiveSheet.Delete
        Sheets("路径").Cells.Delete
        Err.Clear: On Error GoTo 0
    End If
    Set Sh = Sheets("路径")
    Sh.[a1] = "D:\" '以查找D盘下所有EXCEL文件为例
    i = 1
    Do While Sh.Cells(i, 1) <> ""
        dirdir (Sh.Cells(i, 1))
        i = i + 1
    Loop
        On Error Resume Next
    Sheets.Add.Name = "XLS文件"
    If Err.Number <> 0 Then
        ActiveSheet.Delete
        Sheets("XLS文件").Cells.Delete
        Err.Clear: On Error GoTo 0
    End If
    Set sh2 = Sheets("XLS文件")
    sh2.Cells(1, 1) = "文件清单"
    For Each cel In Sh.[a1].CurrentRegion
        Call dirf(cel.Value)
    Next
End Sub
Sub dirf(My_Path) '遍历文件夹下的所有EXCEL文件
    Set sh2 = Sheets("XLS文件")
    mm = sh2.[a65536].End(xlUp).Row + 1
    MyFileName = Dir(My_Path & "*.xl*")
    Do While MyFileName <> ""
        sh2.Cells(mm, 1) = My_Path & MyFileName
        mm = mm + 1
        MyFileName = Dir
    Loop
End Sub
Sub dirdir(MyPath) '遍历指定目录下的所有文件夹
    Dim MyName
   Set Sh = Sheets("路径")
    MyName = Dir(MyPath, vbDirectory)
    m = Sh.[a65536].End(xlUp).Row + 1
    Do While MyName <> ""
        If MyName <> "." And MyName <> ".." Then
            If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
                Sh.Cells(m, 1) = MyPath & MyName & "\"
                m = m + 1
            End If
        End If
        MyName = Dir
    Loop
End Sub