Question

如何用VBA遍历指定目录下的所有子文件夹Excel文件的所有工作表

Answer 1

vba麻烦点，dir最快，excelhome论坛上有大量现成代码：

Sub Opiona() '//函数实例
FileArr = FileAllArr(ThisWorkbook.Path, "*.xls", ThisWorkbook.Name, False)
For i = 0 To UBound(FileArr )
    MsgBox FileArr (i)
    'Set WB = Workbooks.Open(FileArr (I))  '//打开工作簿
    '你的代码
    'WB.Close true  '//保存
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
'****************************************************************