Excel VBA获取当文件下级子目录或目录中文件

'======================================================================
'功能：    查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）
'函数名：  getAllSubDirs
'参数1：   ThisDirPath     需查找的文件夹名,最后可以有或没有"\"
'参数2：   Files           是否只要文件夹名，可省略，默认为：FALSE
'参数3：   FileFilter      过滤文件文件名，可适用于like支持形式
'返回值：  一个Variant型的数组
'=======================================================================
Function getAllSubDirs(ByVal ThisDirPath As String, _
              Optional ByVal Files As Boolean = False, _
              Optional ByVal FileFilter As String = "*.*") As Variant()
'======代码开始==============
Dim arr(), arrFileFullNames() 'arr为存储文件夹数组，arrFileFullNames存储文件数组
Dim DirName, thePath As String 'DirName为当前查询文件夹或文件，thePath为当前查询文件夹路径,ThisDirPath为指定查询的最上层文件夹路径
Dim i, j, k, m As Integer

ThisDirPath = ThisDirPath & IIf(Right(ThisDirPath, 1) = "\", "", "\") '把指定最上层文件夹路径处理成"\"结尾路径
i = 0: j = 0: k = 0: m = 0
ReDim Preserve arr(j)
arr(j) = ThisDirPath

Do While j < UBound(arr) + 1
    thePath = arr(j)
    DirName = Dir(thePath, vbDirectory)
    Do While DirName <> ""
        If DirName <> "." And DirName <> ".." Then
           If (GetAttr(thePath & DirName) And vbDirectory) = vbDirectory Then    '如果是次级目录
               i = i + 1
               ReDim Preserve arr(i)
               arr(i) = thePath & DirName & "\"
           ElseIf thePath <> ThisDirPath And (DirName Like FileFilter) Then '如果非本工作簿所在文件夹文件，则文件全名存入数组
                ReDim Preserve arrFileFullNames(k)
                arrFileFullNames(k) = thePath & DirName
                k = k + 1
           End If
                
        End If
        DirName = Dir
    Loop
    j = j + 1
Loop
'==========声明一个数组arrDirs接收arr数组除首个元素外数据（首个元素为指定文件夹本身）=====
If i > 0 And Not Files Then 'i为0则没有下层文件夹
    ReDim arrDirs(0 To UBound(arr) - 1)
    For m = 1 To UBound(arr)
        arrDirs(m - 1) = arr(m)
    Next
    Erase arr
    Erase arrFileFullNames
    getAllSubDirs = arrDirs
ElseIf k > 0 And Files Then 'k为0则下层文件夹没有文件
    Erase arrDirs
    Erase arr
    getAllSubDirs = arrFileFullNames
Else
    arr(0) = ""
    getAllSubDirs = arr(0)
End If
End Function



'=======================================================================================================
'函数:   getFileNameFromFullName   根据文件带全路径全名获得文件名
'参数1： strFullName  文件全名
'参数2： ifExName true 返回字符串含扩展名,默认是：False
'参数3： strSplitor  各级文件夹分隔符
'作用:  从带路径文件全名径获取返回:  文件名(true带扩展名)
'=======================================================================================================
Public Function getFileNameFromFullName(ByVal strFullName As String, _
                               Optional ByVal ifExName As Boolean = False, _
                               Optional ByVal strSplitor As String = "\") As String
    '=======代码开始==============================================================================
    Dim ParentPath As String
    Dim FileName As String
    ParentPath = Left$(strFullName, InStrRev(strFullName, strSplitor, , vbTextCompare)) '反向查找路径分隔符，获取文件父级目录
    FileName = Replace(strFullName, ParentPath, "") '替换父级目录为空得到文件名
    If ifExName = False Then
        getFileNameFromFullName = Left(FileName, InStrRev(FileName, ".") - 1) '返回不带扩展名文件名
    Else
        getFileNameFromFullName = FileName '返回带扩展名文件名
    End If
End Function
'=======================================================================================================


Function isEmptyArr(ByRef arr()) As Boolean   '判断是否为空数组
Dim tempStr As String
tempStr = Join(arr, ",")
isEmptyArr = LenB(tempStr) <= 0
End Function

测试代码：

Sub test()
Dim arr()
Dim mypath As String
mypath = ThisWorkbook.Path
arr = getAllSubDirs(mypath, True, "*.xls")
If isEmptyArr(arr) Then
    MsgBox "路径无效，退出程序！"
    Exit Sub
End If
Range("a1").Resize(UBound(arr) + 1, 1) = Application.Transpose(arr)


End Sub

原文件下载