從網上找了一些資訊，自己修改了一下

方式很直白，先把所有的目錄找了出來，然後一個個目錄來處理。

雖然與我習慣使用迭代的的方式有所差別，但也很好。

後面的函式是原始的，沒有改動，主函式自己重新寫過了。

檔案下載

 '主函式
    
 Sub ListFilesInCurFolder() '//函式例項

    Cells(1, 1) = "序號"
    Cells(1, 2) = "檔名稱"
    Cells(1, 3) = "檔案型別"
     Cells(1, 4) = "路徑"


Dim strCurfileName
Dim CurRow
CurRow = 2


    arr = FileAllArr(ThisWorkbook.Path, "*.*", ThisWorkbook.Name)
    For I = 0 To UBound(arr)
       ' MsgBox arr(I)
        'Set WB = Workbooks.Open(arr(I))
        '你的程式碼
        'WB.Close False
        
        
            'lj = "E:\ToolDev\ExcelTools\ListFileInFolder\test"
    

    
    Dim wj As String
    
    'wj = Dir(lj & "\*.*")
    
 
        Dim idx As Integer
        idx = InStrRev(arr(I), "\")
        If idx >= 0 Then
            strCurfileName = Mid(arr(I), idx + 1, Len(arr(I)))
        Else
            strCurfileName = arr(I)
        End If

    
        'Cells(([A65536].End(xlUp).Row + 1), 1) = [A65536].End(xlUp).Row
       ' Cells(([C65536].End(xlUp).Row + 1), 3).FormulaR1C1 = "=MID(RC[-1],FIND(""."",RC[-1])+1,LEN(RC[-1]) - FIND(""."",RC[-1]))"
       ' Cells(([B65536].End(xlUp).Row + 1), 2).Select
      Cells(CurRow, 1) = CurRow - 1

    Cells(CurRow, 3).FormulaR1C1 = "=MID(RC[-1],FIND(""."",RC[-1])+1,LEN(RC[-1]) - FIND(""."",RC[-1]))"
        
            Cells(CurRow, 2).Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=arr(I), TextToDisplay:=strCurfileName
       
            '相對路徑，但證明無用，絕對路徑，在excel中，會被自動轉為相對路徑
            'Cells(CurRow, 4).Select
            'Dim RefPath
            'RefPath = Mid(arr(I), Len(ThisWorkbook.Path) + 2, Len(arr(I)))
            'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=RefPath, TextToDisplay:=strCurfileName
        
       '''''''''''''
       Cells(CurRow, 4).Select
       Dim CurFolder
      CurFolder = Left(arr(I), idx)
      
      CurFolder = Mid(CurFolder, Len(ThisWorkbook.Path) + 2, Len(CurFolder))
      
      Cells(CurRow, 4) = CurFolder
      
        CurRow = CurRow + 1
    Next
    
    
        Columns("A:C").Select
        Columns("A:C").EntireColumn.AutoFit
    End Sub
    '****************************************************************
    '功能：    查詢指定資料夾含子資料夾內所有檔名（含路徑）
    '函式名：  FileAllArr
    '引數1：   Filename    需查詢的資料夾名 不含最後的"\"
    '引數2：   FileFilter  需要過濾的檔名，可省略，預設為：[*.*]
    '引數3：   Liwai       剔除例外的檔名，可省略，預設為：空，一般為：ThisWorkbook.Name
    '返回值：  一個字元型的陣列
    '使用方法：arr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name)

    Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "") As String()
        Set Dic = CreateObject("Scripting.Dictionary")    '建立一個字典物件
        Set Did = CreateObject("Scripting.Dictionary")
        Dic.Add (Filename & "\"), ""
        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
      
    I = 0
    Dim arrx() As String
        For Each Ke In Dic.keys '以查詢總表所在資料夾下所有excel檔案為例
            MyFileName = Dir(Ke & FileFilter) '過濾器：EXCEL2003為：*.xls,excel2007為：*.xlsx
            Do While MyFileName <> ""
               If MyFileName <> Liwai Then '排除例外檔案
                  ReDim Preserve arrx(I)
                  arrx(I) = Ke & MyFileName
                  I = I + 1
               End If
                MyFileName = Dir
            Loop
        Next
        FileAllArr = arrx
    End Function
    '****************************************************************




    'Sub g1()

     '   Dim fso, fl, m&
    '    Set fso = CreateObject("Scripting.FileSystemObject")
    '    For Each fl In fso.getfolder(CreateObject("Shell.Application").BrowseForFolder(0, "請選擇資料夾", 0, "").Self.Path & "\").Files
   '        m = m + 1
   '        Cells(m, 2) = fl.Name
   '     Next

 '   End Sub
 

檔案下載