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

考试加油站

liulang0808 发表于 2019-12-31 12:57
超级链接，录制一段宏，然后修改即可
修改文件名使用name as，在另外一个帖子有说明

谢谢，能在你的这个上面加上一个详细代码吗 四、遍历当前文件夹及所有子文件夹下的文件.zip (63.6 KB, 下载次数: 21)

2019-12-31 16:18 上传

点击文件名下载附件

liulang0808

考试加油站 发表于 2019-12-31 16:15
谢谢，能在你的这个上面加上一个详细代码吗

Sub °′Å￥1_Click()
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.ClearContents
    Cells(1, 1) = "Ïà¶Ô·¾¶ÎļtÃû"
    Cells(1, 2) = "¾ø¶Ô·¾¶ÎļtÃû"
    Getfd (ThisWorkbook.Path) 'ThisWorkbook.PathêÇμ±Ç°′úÂëÎļtËùÔú·¾¶￡¬Â·¾¶Ãû¿éòÔ¸ù¾YDèÇóDT¸Ä
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth)
    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
    For Each f In ff.Files
        Rem ¾ßìåìáè¡ÄÄààÎļt￡¬»1êÇDèòa¸ù¾YÎļtà©Õ1Ãû½øDD′|àí
'        Cells(Rows.Count, 1).End(3).Offset(1) = f.Name
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(Rows.Count, 1).End(3).Offset(1), Address:=f, TextToDisplay:=f.Name
        Cells(Rows.Count, 2).End(3).Offset(1) = f
    Next f
    For Each fd In ff.subfolders
        Getfd (fd)
    Next fd
End Sub
文件改名，使用name as另外的帖子有，自己看吧

zhoubocz

老师，请问这个遍历支持.xlsm类型的文件吗

liulang0808

zhoubocz 发表于 2020-1-7 14:13
老师，请问这个遍历支持.xlsm类型的文件吗

支持，可以测试看看的

dddd12345678

先收藏下，有时间看

lukeluckc

非常有用的资料 帮了大忙啦~~~

dongguan123

谢谢分享对对对对对对

小飞龙x'x'x

五、汇总当前文件夹及子文件夹下所有excel文件内容
这个代码用的的字典,好处是数据合并是进行了运算.缺点是只能合并两列.

对于有将文件夹下所有EXCEL sheet下的内容合并到一个sheet需求时，做了部分修改。
Public d
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.ClearContents
    Cells(1, 1) = "编号"
    Cells(1, 2) = "数量"
    Set d = CreateObject("scripting.dictionary")
    Getfd (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 Getfd(ByVal pth)

    Set Fso = CreateObject("scripting.filesystemobject")
    Set ff = Fso.getfolder(pth)
    For Each f In ff.Files   '文件夹下的所有文件，除了文件夹
        Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理
        If InStr(Split(f.Name, ".")(UBound(Split(f.Name, "."))), "xl") > 0 Then   '判断是否为xlms文件 。
            If InStr(f.Name, ThisWorkbook.Name) = 0 Then   '文件中不包括当前excel
                Set wb = Workbooks.Open(f)
                For Each sht In wb.Sheets            'sheets中的每个sheet
                    If WorksheetFunction.CountA(sht.UsedRange) > 1 Then
                        aa = ThisWorkbook.ActiveSheet.Range("A65536").End(xlUp).Row + 1 'aa是便于将内容依次复制到当前sheet
                        sht.UsedRange.Copy ThisWorkbook.ActiveSheet.Cells(aa, 1) '将sht内容复制到当前sheet
                    End If
                Next sht
                wb.Close False
            End If
        End If
    Next f
    For Each fd In ff.subfolders  '遍历文件夹下的所有子文件夹
        Getfd (fd)
    Next fd
End Sub

nanbinghu

收藏备用汇总！

li369bang

小飞龙x'x'x 发表于 2020-2-28 22:26
五、汇总当前文件夹及子文件夹下所有excel文件内容
这个代码用的的字典,好处是数据合并是进行了运算.缺点 ...

你好！如果第四个，我想要对当前文件夹的所有子文件夹进行处理（不含当前文件夹），该怎么改这个代码？谢谢！

四、遍历当前文件夹及所有子文件夹下的文件
还是递归

Sub 按钮1_Click()
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.ClearContents
    Cells(1, 1) = "相对路径文件名"
    Cells(1, 2) = "绝对路径文件名"
    Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth)
    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
        Getfd (fd)
    Next fd
End Sub