fso提取汇总文件夹及其下的文件名及内容（递归操作字典汇总）

Sub bl() '递归遍历文件夹及子文件夹中的文件
Dim SearchPath
Dim DicList, FileList, I, FileName(), FilePath()
Set DicList = CreateObject("Scripting.Dictionary")
Set FileList = CreateObject("Scripting.Dictionary")
SearchPath = "D:\PDF\"
DicList.Add SearchPath, ""  '初始化目录
'**************遍历所有目录*******************
I = 0
Do While I < DicList.Count
    Key = DicList.Keys '本次要遍历的目录
    NowDic = Dir(Key(I), vbDirectory) '开始查找
    Do While NowDic <> ""
        If (NowDic <> ".") And (NowDic <> "..") Then
            If (GetAttr(Key(I) & NowDic) And vbDirectory) = vbDirectory Then '找到子目录，则添加
                DicList.Add Key(I) & NowDic & "\", ""
            End If
        End If
        NowDic = Dir() '再找
    Loop
    I = I + 1
Loop
'****************************************************
'**************遍历目录中的所有文件*******************
For Each Key In DicList.Keys '查找所有目录中的文件
   NowFile = Dir(Key & "*.pdf")
   Do While NowFile <> ""
        FileList.Add NowFile, Key 'Add(Key,Item)  FileList.Key=文件名,FileList.Item=目录
        NowFile = Dir()
   Loop
Next
FileName() = FileList.Keys
FilePath() = FileList.Items
'****************************************************
End Sub

Sub 按钮1_Click() '一、遍历当前文件夹下一层子文件夹
    Dim Fso As Object, ff As Object, a&, fd As Object
    Application.ScreenUpdating = False
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    ActiveSheet.UsedRange.ClearContents
    a = 1
    For Each fd In ff.subfolders
        Cells(a, 1) = fd.Name '子文件夹名,相对于当前文件夹的名字
        Cells(a, 2) = fd '子文件夹全路径
        a = a + 1
    Next fd
    Application.ScreenUpdating = True
End Sub

Sub 按钮2_Click() '二、提取当前文件夹下的文件名称(完整路径名)
    Dim Fso As Object, ff As Object, a&, fd As Object
    Application.ScreenUpdating = False
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    ActiveSheet.UsedRange.ClearContents
    a = 1
    For Each f In ff.Files
        Rem 如果不需要提取本代码文件名，可以增加if语句 if f.name<> thisworkbook.name then.....
        Rem 如果值需要提取某类文件，需要对f.name的扩展名进行判断
        Rem 个人感觉split取 扩展名：split（f.name,".")(ubound（split（f.name,".")）)，然后再判断，避免文件名还有其他“.”
        Cells(a, 1) = f.Name '相对路径名
        Cells(a, 2) = f '全路径名
        a = a + 1
    Next f
    Application.ScreenUpdating = True
End Sub

Sub 按钮4_Click() '四、遍历当前文件夹及所有子文件夹下的文件
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.ClearContents
    Cells(1, 1) = "相对路径文件名"
    Cells(1, 2) = "绝对路径文件名"
    Getfd1 (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    Application.ScreenUpdating = True
End Sub
Public d
Sub 按钮5_Click() '五、汇总当前文件夹及子文件夹下所有excel文件内容
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.ClearContents
    Cells(1, 1) = "编号"
    Cells(1, 2) = "数量"
    Set d = CreateObject("scripting.dictionary")
    Getfd2 (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    Application.ScreenUpdating = True
    If d.Count > 0 Then
        ThisWorkbook.Sheets(1).[a2].Resize(d.Count) = WorksheetFunction.Transpose(d.Keys)
        '如果D.COUNT >65536,就需要调整，不能使用Transpose，因为Transpose 只支持65536以内数据
        ThisWorkbook.Sheets(1).[b2].Resize(d.Count) = WorksheetFunction.Transpose(d.Items)
    End If
    d.RemoveAll
End Sub

Sub Getfd2(ByVal pth)
    Dim Fso As Object, ff As Object, a&, fd As Object, f As Object, wb As Workbook, j&, arr, sht
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
    Set d = CreateObject("scripting.dictionary")
    For Each f In ff.Files
        Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理
        If InStr(Split(f.Name, ".")(UBound(Split(f.Name, "."))), "xl") > 0 Then
            If f.Name <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(f)
                For Each sht In wb.Sheets
                    If WorksheetFunction.CountA(sht.UsedRange) > 1 Then
                        arr = sht.UsedRange
                        For j = 2 To UBound(arr)
                            d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
                        Next j
                    End If
                Next sht
                wb.Close False
            End If
        End If
    Next f
    For Each fd In ff.subfolders
        Getfd2 (fd)
    Next fd
End Sub

Sub Getfd1(ByVal pth)
    Dim Fso As Object, ff As Object, a&, fd As Object, f As Object
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
    For Each f In ff.Files
        Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理
        Cells(Rows.Count, 1).End(3).Offset(1) = f.Name '文件名
        Cells(Rows.Count, 2).End(3).Offset(1) = f '完整路径文件名
    Next f
    For Each fd In ff.subfolders
        Getfd1 (fd)
    Next fd
End Sub

Sub 按钮3_Click() '三、遍历当前文件夹所有子文件夹
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.ClearContents
    Cells(1, 1) = "文件夹名"
    Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    Application.ScreenUpdating = True
End Sub

Sub Getfd(ByVal pth)
    Dim Fso As Object, ff As Object, a&, fd As Object
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
    Cells(Rows.Count, 1).End(3).Offset(1) = pth
    For Each fd In ff.subfolders
        Getfd (fd)
    Next fd
End Sub