提取文件夹及子文件夹数据方法

乐乐2006201505

所有代码都是从网上搜集或论坛大师帮助过我的。帖子中的代码参照了香川群子老师递归代码。函数法是北极狐老师的，还有bajifeng老师和liulang0808老师的代码，都非常好，有些想不起来借鉴哪位老师的了，但是在此处一并感谢！
汇总分享出来，让有需要的坛友下载使用，希望能尽一点绵薄之力。
有些思路是一致的，但换了部分字眼，有些是思路一样，稍有差异。
也欢迎论坛其他高手补充更多方法或完善已有代码。不胜感激！
第一种方法：
Sub 合并表格()
Cells.ClearContents
Application.ScreenUpdating = False
Range("A1:C1") = Array("公司名", "产品", "金额")    '此处为填写标题行，可以提前做好，也可以通过数组赋值
Dim arr(1 To 1000) As String
Dim F, cFile, i%, k%, x%
Dim wb As Workbook
arr(1) = ThisWorkbook.Path & "\"
i = 1: k = 1
Do While i < UBound(arr)
    If arr(i) = "" Then Exit Do
    F = Dir(arr(i), vbDirectory)
    Do
        If InStr(F, ".") = 0 And F <> "" Then
            k = k + 1
            arr(k) = arr(i) & F & "\"
        End If
        F = Dir
    Loop Until F = ""
    i = i + 1
Loop

For x = 2 To UBound(arr)
    If arr(x) = "" Then Exit For
    cFile = Dir(arr(x) & "*.xls?")
    Do While cFile <> ""
        Set wb = Workbooks.Open(arr(x) & cFile)
        '下面红色代码为自己可以修改的代码，wb包含了本文件夹及子文件夹中所有excel文件，Sheets("销售")是指定工作表名为销售的工作表，可自行修改，如果要遍历所有工作表，就用for each sh in sheets …… next 方法遍历。
        With wb.Sheets("销售")
            .Range("A2:C" & .Range("C65536").End(3).Row).Copy ThisWorkbook.Sheets("销售").Range("A65536").End(3).Offset(1, 0)
        End With
        wb.Close
        cFile = Dir
    Loop
Next x
Application.ScreenUpdating = True
End Sub
http://wenda.so.com/q/1373444802068826

wz1497

我一般用的是filesystemobject

乐乐2006201505

第二种方法：
Sub 父子转换法()
  'On Error Resume Next
  Dim 父亲(1 To 1000) As String
  Dim F, i, i1, i3, k, f2, f3, x, sh As Worksheet
  Dim arr1(1 To 1000, 1 To 1) As String, q As Integer
  Dim arr(1 To 1000, 1 To 70)
  Dim T#
  Dim maxh&
  T = Timer
  父亲(1) = ThisWorkbook.Path & "\"
  i = 1: k = 1
  Do While i < UBound(父亲)
    If 父亲(i) = "" Then Exit Do
    F = Dir(父亲(i), vbDirectory)
    Do
      If InStr(F, ".") = 0 And F <> "" Then
        k = k + 1
        父亲(k) = 父亲(i) & F & "\"
      End If
      F = Dir
    Loop Until F = ""
    i = i + 1
  Loop
  '*******下面是提取各个文件夹的文件***
  For x = 1 To UBound(父亲)
      If 父亲(x) = "" Then Exit For
       f3 = Dir(父亲(x) & "*.xls?")
     Do While f3 <> ""
        If f3 <> ThisWorkbook.Name Then
          q = q + 1
          arr1(q, 1) = 父亲(x) & f3
         
          Workbooks.Open arr1(q, 1)
               With ActiveWorkbook
                      With .Sheets("销售")
                              .Range("A2:C" & .Range("C65536").End(3).Row).Copy ThisWorkbook.Sheets("销售").Range("A65536").End(3).Offset(1, 0)
                      End With
               .Close False
               End With
        End If
        f3 = Dir
     Loop
  Next x
  MsgBox Format(Timer - T, "0.00000")
End Sub

乐乐2006201505

第三种方法：
Sub mysumup遍历指定夹中所有夹含子夹()
    Application.ScreenUpdating = False
    Dim sh As Object, ar, br, i&, myPath$, j%, rng As Range, str$
    Set sh = CreateObject("wscript.shell")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        myPath = .SelectedItems(1) & "\"
    End With
    myPath = sh.Exec("cmd /c dir /a /s /b /a-d " & Chr(34) & myPath & "*.xls*" & Chr(34)).StdOut.ReadAll
    If Len(myPath) Then myPath = Left(myPath, Len(myPath) - 1) Else Exit Sub
    ar = Split(myPath, vbCrLf)
        ReDim br(1 To UBound(ar) + 1, 1 To 1)
        For i = 0 To UBound(ar)
            br(i + 1, 1) = ar(i)
        Next
        Rows("2:65536").ClearContents
        For j = 1 To UBound(br)
            If Not (br(j, 1) Like ThisWorkbook.Path & "\*汇总.xlsm") Then
            Set rng = Cells(Rows.Count, 1).End(3).Offset(1)
                str = "='" & WorksheetFunction.Replace(WorksheetFunction.Substitute(WorksheetFunction.Substitute(br(j, 1), _
                Chr(10), ""), Chr(13), ""), InStrRev(br(j, 1), "\"), 1, "\[") & "]Sheet1'!"
                rng.Formula = str & "$A$2": rng.Offset(, 1).Formula = str & "$B$2": rng.Offset(, 2).Formula = str & "$B$10"
                    With rng.Resize(1, 3)
                        .Value = .Value
                    End With
            End If
        Next
    Set sh = Nothing
    Application.ScreenUpdating = True
End Sub

乐乐2006201505

第四种方法：
Sub test() '使用双字典，旨在提高速度
    Dim myName, dic, Did, i, T, F, TT, MyFileName
    T = Time
    Set dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    dic.Add (ThisWorkbook.Path & "\"), ""
    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 <> ""
            If MyFileName Like "*.xls" Or MyFileName Like "*.xlsx" Then
                Did.Add (Ke & MyFileName), ""
            End If
            MyFileName = Dir
        Loop
    Next

'    k = Did.keys   '此代码可以提取指定字典中的值

    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

乐乐2006201505

第五种方法：
Sub test()
Dim myPath, myName, MyFileName, dic, d, i&, arr
    Set dic = CreateObject("Scripting.Dictionary")
    Set d = CreateObject("Scripting.Dictionary")
    Application.DisplayAlerts = False
    myPath = ThisWorkbook.Path & "\"
    dic.Add (myPath), ""
    Do While i < dic.Count
        arr = dic.keys
        myName = Dir(arr(i), vbDirectory)
        Do While myName <> ""
            If myName <> "." And myName <> ".." Then
                If (GetAttr(arr(i) & myName) And vbDirectory) = vbDirectory Then
                    dic.Add (arr(i) & myName & "\"), ""
                End If
            End If
            myName = Dir
        Loop
        i = i + 1
    Loop
    For Each arr In dic.keys
        MyFileName = Dir(arr & "*.xls")
        Do While MyFileName <> "" And MyFileName <> ThisWorkbook.Name
            d.Add (arr & MyFileName), ""
            MyFileName = Dir
        Loop
    Next
'    For Each arr In dic.keys
'        MyFileName = Dir(arr & "*.doc")
'        Do While MyFileName <> "" And MyFileName <> ThisWorkbook.Name
'            d.Add (arr & MyFileName), ""
'            MyFileName = Dir
'        Loop
'    Next
    Range("A2:Z65536").ClearContents
    [E2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
    For i = 2 To Cells(65536, 5).End(3).Row
        arr = Split(Cells(i, 5), "\")
        Cells(i, 1) = arr(UBound(arr))
        Cells(i, 2) = arr(UBound(arr) - 3)
        Cells(i, 3) = arr(UBound(arr) - 2)
        Cells(i, 4) = arr(UBound(arr) - 1)
    Next
    Columns(5).ClearContents
    Application.DisplayAlerts = True
End Sub

乐乐2006201505

第三种方法：
Sub mysumup遍历指定夹中所有夹含子夹()
    Application.ScreenUpdating = False
    Dim sh As Object, ar, br, i&, myPath$, j%, rng As Range, str$
    Set sh = CreateObject("wscript.shell")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        myPath = .SelectedItems(1) & "\"
    End With
    myPath = sh.Exec("cmd /c dir /a /s /b /a-d " & Chr(34) & myPath & "*.xls*" & Chr(34)).StdOut.ReadAll
    If Len(myPath) Then myPath = Left(myPath, Len(myPath) - 1) Else Exit Sub
    ar = Split(myPath, vbCrLf)
        ReDim br(1 To UBound(ar) + 1, 1 To 1)
        For i = 0 To UBound(ar)
            br(i + 1, 1) = ar(i)
        Next
        Rows("2:65536").ClearContents
        For j = 1 To UBound(br)
            If Not (br(j, 1) Like ThisWorkbook.Path & "\*汇总.xlsm") Then
            Set rng = Cells(Rows.Count, 1).End(3).Offset(1)
                str = "='" & WorksheetFunction.Replace(WorksheetFunction.Substitute(WorksheetFunction.Substitute(br(j, 1), _
                Chr(10), ""), Chr(13), ""), InStrRev(br(j, 1), "\"), 1, "\[") & "]Sheet1'!"
                rng.Formula = str & "$A$2": rng.Offset(, 1).Formula = str & "$B$2": rng.Offset(, 2).Formula = str & "$B$10"
                    With rng.Resize(1, 3)
                        .Value = .Value
                    End With
            End If
        Next
    Set sh = Nothing
    Application.ScreenUpdating = True
End Sub

乐乐2006201505

第六种方法：
'*********************************
'*******  北极狐工作室出品  ******
'*******  QQ：14885553      ******
'*********************************

Sub Opiona() '//函数实例

FileArr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name, False)
For i = 0 To UBound(FileArr)
    arr = Split(FileArr(i), "\")
    Sheet1.Cells(i + 2, 1) = arr(UBound(arr))
    Sheet1.Cells(i + 2, 2) = arr(UBound(arr) - 3)
    Sheet1.Cells(i + 2, 3) = arr(UBound(arr) - 2)
    Sheet1.Cells(i + 2, 4) = arr(UBound(arr) - 1)
Next

End Sub
'*******************************************************************************************************
'功能：    查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）
'函数名：  FileAllArr
'参数1：   Filename    需查找的文件夹名 不含最后的""
'参数2：   FileFilter     需要过滤的文件名，可省略，默认为：[*.*]
'参数3：   Liwai           剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
'参数4：   Files           是否只要文件夹名，可省略，默认为：FALSE
'返回值：  一个字符型的数组
'使用方法：FileArr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name,false)
'作者:    北极狐工作室 QQ：14885553
'*******************************************************************************************************
Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = "*.*", Optional ByVal Liwai As String = "", Optional ByVal Files As Boolean = False) As String()
    Set dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    dic.Add (Filename & "\"), ""
    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
    Dim arrx() As String
    i = 0
    If Files = True Then   '//是否只输出文件夹名
      
        For Each Ke In dic.keys '以查找总表所在文件夹下所有excel文件为例
            ReDim Preserve arrx(i)
            If Ke <> Filename & "" Then  '//自身文件夹除外
                arrx(i) = Ke
                i = i + 1
            End If
         Next
         FileAllArr = arrx
    Else
        For Each Ke In dic.keys '以查找总表所在文件夹下所有excel文件为例
            MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
            Do While MyFileName <> ""
               If MyFileName <> Liwai Then '排除例外文件
                  ReDim Preserve arrx(i)
                  arrx(i) = Ke & MyFileName
                  i = i + 1
               End If
                MyFileName = Dir
            Loop
        Next
        FileAllArr = arrx
    End If
End Function
'*******************************************************************************************************

乐乐2006201505

第七种方法：
'终于修改好了，期待更简便的方法。
Sub Test11()
'可以排除本身文件，不需将本身文件放到文件夹外
Dim startfolder As String
Dim arr(1 To 500, 1 To 70), i%
startfolder = "C:\Users\YYB\Desktop\递归法提取数据 未实现\"     '指定文件夹
Set folderlist = CreateObject("scripting.dictionary")
Set filelist = CreateObject("scripting.dictionary")
i1 = 1
folderlist.Add startfolder, ""
Do While folderlist.Count > 0
    For Each FolderName In folderlist.keys
    fName = Dir(FolderName, vbDirectory)
        Do While fName <> ""
            If fName <> ".." And fName <> "." Then
                If GetAttr(FolderName & fName) And vbDirectory Then
                    folderlist.Add FolderName & fName & "\", ""
                Else
                    filelist.Add FolderName & fName, ""    '这里列出的该文件的路径＋文件名
                End If
            End If
        fName = Dir
        Loop
    folderlist.Remove (FolderName)
    Next
Loop
      
Windows("递归.xlsm").Activate
    For Each F In filelist.keys       '将文件路径＋文件名放在当前工作表的A列
        If Mid(F, Len(ThisWorkbook.Path) + 2, Len(F) - Len(ThisWorkbook.Path) - 1) <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(F)
            With wb
                With .Sheets(1)
                    i = i + 1
                    arr(i, 1) = .Range("D1")
                    arr(i, 2) = .Range("J1")
                    arr(i, 3) = .Range("O1")
                    arr(i, 4) = .Range("E7")
                    arr(i, 5) = .Range("E8")
                    arr(i, 6) = .Range("E9")
                    arr(i, 7) = .Range("E10")
                    arr(i, 8) = .Range("E11")
                    arr(i, 9) = .Range("E12")
                    arr(i, 10) = .Range("E13")
                    arr(i, 11) = .Range("M7")
                    arr(i, 12) = .Range("M8")
                    arr(i, 13) = .Range("M9")
                    arr(i, 14) = .Range("M10")
                    arr(i, 15) = .Range("M11")
                    arr(i, 16) = .Range("M12")
                    arr(i, 17) = .Range("B7")
                    arr(i, 18) = .Range("B8")
                    arr(i, 19) = .Range("B9")
                    arr(i, 20) = .Range("B10")
                    arr(i, 21) = .Range("B11")
                    arr(i, 22) = .Range("B12")
                    arr(i, 23) = .Range("B13")
                    arr(i, 24) = .Range("J7")
                    arr(i, 25) = .Range("J8")
                    arr(i, 26) = .Range("J9")
                    arr(i, 27) = .Range("J10")
                    arr(i, 28) = .Range("J11")
                    arr(i, 29) = .Range("J12")
                    arr(i, 30) = .Range("J15")
                    arr(i, 31) = .Range("J16")
                    arr(i, 32) = .Range("J17")
                    arr(i, 33) = .Range("J18")
                    arr(i, 34) = .Range("J19")
                    arr(i, 35) = .Range("J20")
                    arr(i, 36) = .Range("J21")
                    arr(i, 37) = .Range("J22")
                    arr(i, 38) = .Range("J23")
                    arr(i, 39) = .Range("J24")
                    arr(i, 40) = .Range("J25")
                    arr(i, 41) = .Range("J26")
                    arr(i, 42) = .Range("J27")
                    arr(i, 43) = .Range("J28")
                    arr(i, 44) = .Range("J29")
                    arr(i, 45) = .Range("J30")
                    arr(i, 46) = .Range("J31")
                    arr(i, 47) = .Range("J32")
                    arr(i, 48) = .Range("J33")
                    arr(i, 49) = .Range("J34")
                    arr(i, 50) = .Range("C15")
                    arr(i, 51) = .Range("C16")
                    arr(i, 52) = .Range("C17")
                    arr(i, 53) = .Range("C18")
                    arr(i, 54) = .Range("C19")
                    arr(i, 55) = .Range("C20")
                    arr(i, 56) = .Range("C21")
                    arr(i, 57) = .Range("C22")
                    arr(i, 58) = .Range("C23")
                    arr(i, 59) = .Range("C24")
                    arr(i, 60) = .Range("C25")
                    arr(i, 61) = .Range("C26")
                    arr(i, 62) = .Range("C27")
                    arr(i, 63) = .Range("C28")
                    arr(i, 64) = .Range("C29")
                    arr(i, 65) = .Range("C30")
                    arr(i, 66) = .Range("C31")
                    arr(i, 67) = .Range("C32")
                    arr(i, 68) = .Range("C33")
                    arr(i, 69) = .Range("C34")
                End With
                arr(i, 70) = .Name
                .Close False
            End With
            [a2].Resize(5000, 70).ClearContents
            [a2].Resize(5000, 70).Borders.LineStyle = xlNone
            [a2].Resize(i, 70) = arr
            [a2].Resize(i, 70).Borders.LineStyle = 1
        Set wb = Nothing
    End If
    Next
End Sub

乐乐2006201505

第八种方法：
'***********递归获取本文件夹及所有子文件夹下所有文件名，
Dim w(1 To 10000), s%
Sub test()
    p = ThisWorkbook.Path & "\"
    Dim arr(1 To 500, 1 To 70), i%
    On Error Resume Next
    s = 0
    zdir p
    For i = 1 To s
        If w(i) Like "*.xls" Or w(i) Like "*.xlsx" And w(i) <> ThisWorkbook.FullName Then
            Set wb = Workbooks.Open(w(i))
                With wb
               
                    With .Sheets(1)
                        j = j + 1
                        arr(j, 1) = .Range("D1")
                        arr(j, 2) = .Range("J1")
                        arr(j, 3) = .Range("O1")
                        arr(j, 4) = .Range("E7")
                        arr(j, 5) = .Range("E8")
                        arr(j, 6) = .Range("E9")
                        arr(j, 7) = .Range("E10")
                        arr(j, 8) = .Range("E11")
                        arr(j, 9) = .Range("E12")
                        arr(j, 10) = .Range("E13")
                        arr(j, 11) = .Range("M7")
                        arr(j, 12) = .Range("M8")
                        arr(j, 13) = .Range("M9")
                        arr(j, 14) = .Range("M10")
                        arr(j, 15) = .Range("M11")
                        arr(j, 16) = .Range("M12")
                        arr(j, 17) = .Range("B7")
                        arr(j, 18) = .Range("B8")
                        arr(j, 19) = .Range("B9")
                        arr(j, 20) = .Range("B10")
                        arr(j, 21) = .Range("B11")
                        arr(j, 22) = .Range("B12")
                        arr(j, 23) = .Range("B13")
                        arr(j, 24) = .Range("J7")
                        arr(j, 25) = .Range("J8")
                        arr(j, 26) = .Range("J9")
                        arr(j, 27) = .Range("J10")
                        arr(j, 28) = .Range("J11")
                        arr(j, 29) = .Range("J12")
                        arr(j, 30) = .Range("J15")
                        arr(j, 31) = .Range("J16")
                        arr(j, 32) = .Range("J17")
                        arr(j, 33) = .Range("J18")
                        arr(j, 34) = .Range("J19")
                        arr(j, 35) = .Range("J20")
                        arr(j, 36) = .Range("J21")
                        arr(j, 37) = .Range("J22")
                        arr(j, 38) = .Range("J23")
                        arr(j, 39) = .Range("J24")
                        arr(j, 40) = .Range("J25")
                        arr(j, 41) = .Range("J26")
                        arr(j, 42) = .Range("J27")
                        arr(j, 43) = .Range("J28")
                        arr(j, 44) = .Range("J29")
                        arr(j, 45) = .Range("J30")
                        arr(j, 46) = .Range("J31")
                        arr(j, 47) = .Range("J32")
                        arr(j, 48) = .Range("J33")
                        arr(j, 49) = .Range("J34")
                        arr(j, 50) = .Range("C15")
                        arr(j, 51) = .Range("C16")
                        arr(j, 52) = .Range("C17")
                        arr(j, 53) = .Range("C18")
                        arr(j, 54) = .Range("C19")
                        arr(j, 55) = .Range("C20")
                        arr(j, 56) = .Range("C21")
                        arr(j, 57) = .Range("C22")
                        arr(j, 58) = .Range("C23")
                        arr(j, 59) = .Range("C24")
                        arr(j, 60) = .Range("C25")
                        arr(j, 61) = .Range("C26")
                        arr(j, 62) = .Range("C27")
                        arr(j, 63) = .Range("C28")
                        arr(j, 64) = .Range("C29")
                        arr(j, 65) = .Range("C30")
                        arr(j, 66) = .Range("C31")
                        arr(j, 67) = .Range("C32")
                        arr(j, 68) = .Range("C33")
                        arr(j, 69) = .Range("C34")
                    End With
                    arr(j, 70) = .Name
                    .Close False
                End With
                [a2].Resize(5000, 70).ClearContents
                [a2].Resize(5000, 70).Borders.LineStyle = xlNone
                [a2].Resize(j, 70) = arr
                [a2].Resize(j, 70).Borders.LineStyle = 1
               
            Set wb = Nothing
        End If
    Next
End Sub

Sub zdir(p)       '递归获得本文件夹及所有子文件夹内文件名
  Set fs = CreateObject("scripting.filesystemobject")
  For Each F In fs.GetFolder(p).Files
    If F <> ThisWorkbook.FullName Then s = s + 1: w(s) = F
  Next
  For Each m In fs.GetFolder(p).SubFolders
      zdir m
  Next
End Sub