vba遍歷指定的文件夾

Sub filelist()
Dim MyName, Dic, Did, i, t, F, TT, MyFileName
       'On Error Resume Next
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "選擇文件夾", 0, 0)
    If Not objFolder Is Nothing Then lj = objFolder.self.Path & "\"
    Set objFolder = Nothing
    Set objShell = Nothing
  
    t = Time
    Set Dic = CreateObject("Scripting.Dictionary")    '創建一個字典對象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add (lj), ""
    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盤下所有EXCEL文件為例
    For Each Ke In Dic.keys
        MyFileName = Dir(Ke & "*.xls")
        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