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

liulang0808

sulli112 发表于 2020-9-28 10:40
老师，我想问一下，像我这种列标题比较多的，要怎么修改呢，我试过用您那段代码，但是弄出来对不上，想根据 ...

Dim sh
Sub 按钮1_Click()
    Set fso = CreateObject("scripting.filesystemobject")
    Set sh = ActiveSheet
    Application.ScreenUpdating = False
    ActiveSheet.UsedRange.Offset(1).ClearContents
    Call Getfd(ThisWorkbook.Path, fso) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    Application.ScreenUpdating = True
End Sub
Sub Getfd(pth, fso)
   
    Set ff = fso.getfolder(pth)
    For Each f In ff.Files
        If InStr(f.Name, "遍历当前文件夹") = 0 Then
            With Workbooks.Open(f)
                r = sh.Cells(Rows.Count, 1).End(3).Offset(1).Row
                .Sheets(1).[a1].CurrentRegion.Offset(1).Copy sh.Cells(Rows.Count, 1).End(3).Offset(1)
                .Close False
            End With
        End If
    Next f
    For Each fd In ff.subfolders
        Call Getfd(fd, fso)
    Next fd
End Sub

jwjnh001

liulang0808 发表于 2014-11-15 09:54
五、汇总当前文件夹及子文件夹下所有excel文件内容
增加了红色字体部分
Public d

以上代码如果是 .xlsm文件类型，则会出现错误。

算了算了算是

总结的好详细哦

wangbadan123456

liulang0808 发表于 2014-11-15 11:58
ThisWorkbook.Sheets(1).[a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
ThisWorkbook.Shee ...

学到了

安平LH

真是大有帮助

ph378

收藏了

yishang3

liulang0808 发表于 2014-11-15 09:14
五、汇总当前文件夹及子文件夹下所有excel文件内容
Excel文件格式一致，汇总求和，其他需求自行变通容
汇 ...

运用这个+SQL不知道问题出在哪，请老师指导！
Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & "\"
   
   ' [a:a] = ""                    '清空A列
    Call ListAllFso(myPath)   '调用FSO遍历子文件夹的递归过程
   
End Sub

Function ListAllFso(myPath$) '用FSO方法遍历并列出所有文件和文件夹名的【递归过程】
   
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    '用FSO方法得到当前路径的文件夹对象实例 注意这里的【当前路径myPath是个递归变量】

  '  For Each f In fld.Files  '遍历当前文件夹内所有【文件.Files】
  '      [a65536].End(3).Offset(1) = f.Name '在A列逐个列出文件名
  '  Next
Dim cnn As Object, myFile$, SQL$, m%
        
    For Each fd In fld.SubFolders  '遍历当前文件夹内所有【子文件夹.SubFolders】
     '   [a65536].End(3).Offset(1) = " " & fd.Name & ""  '在A列逐个列出子文件夹名
    ' myFile = Dir(fd.Path & "\" & "*.xls*")
      If Right(fd.Path, 1) <> "" Then myPath = fd.Path & "\"
    myFile = Dir(myPath & "*.xls*")
   
    Application.ScreenUpdating = False
    Cells.ClearContents
    [a1:L1] = Array("序号", "学员姓名", "性别", "年龄", "出生年月", "联系电话", "学校", "家庭住址", "所报科目", "采单日期", "市场人员", "采单地址")

    Set cnn = CreateObject("adodb.connection")
    Do While Len(myFile)
        m = m + 1
        If m = 1 Then
            cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & myPath & myFile
            SQL = "select * from [当日市场数据$] where 学员姓名 is not null"
        Else
            SQL = "select * from [Excel 12.0;Database=" & myPath & myFile & "].[当日市场数据$] where 学员姓名 is not null"
        End If
        Range("a" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
        myFile = Dir
    Loop
    With [a1].CurrentRegion
        .Value = .Value
    End With
'    rst.Close
    cnn.Close
    Set cnn = Nothing
   Application.ScreenUpdating = True
        
        Call ListAllFso(fd.Path)       '注意此时的路径变量已经改变为【子文件夹的路径fd.Path】
        '注意重点在这里： 继续向下调用递归过程【遍历子文件夹内所有文件文件夹对象】
    Next
End Function

kdkjblue

大家好
如果想要实现对D列（山东、泰州、青岛）的复制到山东文件夹  ，E 列（江苏、苏州、常州）复制到江苏文件夹，可以再加入一个循环吗？谢谢！
Public arr
Public str1
Public fo


Sub 按钮2_Click()
    For i = 4 To 5
    arr = Range(Cells(i, 1), Cells(i, Cells(Rows.Count, "d").End(3).Row))
    fo = Cells(1, i)
   
    Application.ScreenUpdating = False
    str1 = ThisWorkbook.Path & "\" & fo & "\"
    Getfd (ThisWorkbook.Path)
    Next
    Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth)
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.getfolder(pth)
    If InStr(ff, fo) = 0 Then
        For Each f In ff.Files
            For k = 1 To UBound(arr)
                If InStr(f.Name, arr(k, 1)) > 0 Then
                    fso.CopyFile f, str1, True '拷贝并覆盖
'                    fso.moveFile f, str1 '拷贝并覆盖
'                    fso.DeleteFile f, True '忽略文件只读属性，直接删除
                    Exit For
                End If
            Next k

        Next f
    End If
    For Each fd In ff.subfolders
        Getfd (fd)
    Next fd

End Sub

蕲春小林

厉害厉害厉害厉害厉害厉害厉害厉害厉害

cnwall

向老师学习