选取文件，列举文件（含子文件夹），记录大小信息，限制文件层级

Public temArr
Public temCount As Long

Sub ListFilesTest()
    Dim ws As Worksheet
    ReDim temArr(1 To 1048576, 1 To 4)
    Set ws = ActiveSheet
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
'
    ws.Cells.Delete                   '清空
    temTime = Time
    temCount = 1
    
    
    
    Application.ScreenUpdating = False
'    myPath$ = "\cn1portal.zkw-group.com@sslqwPQF"
    Call ListAllFso(myPath, ws)  '调用FSO遍历子文件夹的递归过程
'    Application.ScreenUpdating = True
'    temArr ws.Cells(1, 1)
    ws.Range(ws.Cells(1, 1), ws.Cells(temCount, 4)) = temArr
'    Call SumFolderSize
    MsgBox "OK " & Time - temTime & "数量:" & temCount
End Sub

Function ListAllFso(myPath$, ws As Worksheet) '用FSO方法遍历并列出所有文件和文件夹名的【递归过程】
    On Error Resume Next
    DoEvents
'    If Len(myPath) - Len(WorksheetFunction.Substitute(myPath, "", "")) > 2 Then Exit Function
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    '用FSO方法得到当前路径的文件夹对象实例 注意这里的【当前路径myPath是个递归变量】
    With ws
        For Each f In fld.Files  '遍历当前文件夹内所有【文件.Files】
            .[a1048576].End(3).Offset(1) = f.Path '在A列逐个列出文件完整路径
            .[a1048576].End(3).Offset(0, 1) = f.Name
            .[a1048576].End(3).Offset(0, 2) = WorksheetFunction.RoundUp(f.Size / 1024, 0)
            .[a1048576].End(3).Offset(0, 4).FormulaR1C1 = "=IF(RC[-2] > 1024 * 1024, ROUNDUP(RC[-2] / 1024 / 1024, 2) & ""G"", IF(RC[-2] > 1024, ROUNDUP(RC[-2] / 1024, 2) & ""M"", RC[-2] & ""K""))"
            .[a1048576].End(3).Offset(0, 3) = Len(f.Path) - Len(WorksheetFunction.Substitute(f.Path, "", ""))
            DoEvents
        Next

        For Each f In fld.SubFolders  '遍历当前文件夹内所有【子文件夹.SubFolders】
            .[a1048576].End(3).Offset(1) = " " & f.Path & ""  '在A列逐个列出子文件夹名
    '        .[a1048576].End(3).Offset(0, 1) = f.Name
            .[a1048576].End(3).Offset(0, 2) = WorksheetFunction.RoundUp(f.Size / 1024, 0)  '直接去文件夹大小，可能会造成系统卡顿，可以先不取，文件下载完后再运行函数SumFolderSize
            .[a1048576].End(3).Offset(0, 4).FormulaR1C1 = "=IF(RC[-2] > 1024 * 1024, ROUNDUP(RC[-2] / 1024 / 1024, 2) & ""G"", IF(RC[-2] > 1024, ROUNDUP(RC[-2] / 1024, 2) & ""M"", RC[-2] & ""K""))"
            .[a1048576].End(3).Offset(0, 3) = Len(f.Path) - Len(WorksheetFunction.Substitute(f.Path, "", ""))

            If Len(f.Path) - Len(WorksheetFunction.Substitute(f.Path, "", "")) < 5 Then Call ListAllFso(f.Path, ws)                 '注意此时的路径变量已经改变为【子文件夹的路径fd.Path】
            '注意重点在这里： 继续向下调用递归过程【遍历子文件夹内所有文件文件夹对象】
            DoEvents
        Next
    End With
End Function
Sub SumFolderSize()
With ActiveSheet
    maxrow = .[a1048576].End(3).Row
    For i = 2 To maxrow
        If .Cells(i, 3) = "" Then
            Sum = 0
            For j = i To maxrow
            temValue = Trim(.Cells(i, 1))
'            Debug.Print Trim(.Cells(i, 1))
'            Debug.Print Left(Trim(.Cells(j, 1)), Len(temValue))
                If Left(Trim(.Cells(j, 1)), Len(temValue)) = temValue Then
                    Sum = Sum + .Cells(j, 3)
                Else
                    .Cells(i, 6) = Sum
                    .Cells(i, 5).FormulaR1C1 = "=IF(RC[1] > 1024 * 1024, ROUNDUP(RC[1] / 1024 / 1024, 2) & ""G"", IF(RC[1] > 1024, ROUNDUP(RC[1] / 1024, 2) & ""M"", RC[1] & ""K""))"
                    Exit For
                End If
                If j = maxrow Then
                    .Cells(i, 6) = Sum
                    .Cells(i, 5).FormulaR1C1 = "=IF(RC[1] > 1024 * 1024, ROUNDUP(RC[1] / 1024 / 1024, 2) & ""G"", IF(RC[1] > 1024, ROUNDUP(RC[1] / 1024, 2) & ""M"", RC[1] & ""K""))"
                End If
                DoEvents
            Next
        Else
            .Cells(i, 5).FormulaR1C1 = "=IF(RC[-2] > 1024 * 1024, ROUNDUP(RC[-2] / 1024 / 1024, 2) & ""G"", IF(RC[-2] > 1024, ROUNDUP(RC[-2] / 1024, 2) & ""M"", RC[-2] & ""K""))"
        End If
        
    Next
End With
MsgBox "OK"
End Sub
Sub ListFilesDos() '文件夹太大内容太多时，出了Bug
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")
    ws.Cells.Delete
'    Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "GetFolder", 0)
'    If Not myFolder Is Nothing Then
'        myPath$ = myFolder.Items.Item.Path
'    Else
'        MsgBox "Folder not Selected"
'        Exit Sub
'    End If

    myPath = "Q:old documents"
'    myFile$ = InputBox("Filename", "Find File", ".xl")
    '在这里输入需要指定的关键字，可以是文件名的一部分，或指定文件类型如 ".xl"
    tms = Timer
    With CreateObject("Wscript.Shell") 'VBA调用Dos命令
    ar = Split(.exec("cmd /c dir  /c /q /s " & Chr(34) & myPath & Chr(34)).StdOut.ReadAll, vbCrLf) '所有文档含子文件夹
    '指定Dos中Dir命令的开关然后提取结果 为指定文件夹以及所含子文件夹内的所有文件的含路径全名。
    s = "from " & UBound(ar) & " Files by Search time: " & Format(Timer - tms, " 0.00s") & " in: " & myPath
    '记录Dos中执行Dir命令的耗时
    tms = Timer:
'    ar = Filter(ar, myFile) '然后开始按指定关键词进行筛选。可筛选文件名或文件类型
    Application.StatusBar = Format(Timer - tms, "0.00s") & " Find " & UBound(ar) + IIf(myFile = "", 0, 1) & " Files " & s
    '在Excel状态栏上显示执行结果以及耗时
    End With
    If UBound(ar) > -1 Then ws.[a2].Resize(1 + UBound(ar)) = WorksheetFunction.Transpose(ar)
    '清空A列，然后输出结果
End Sub