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

原文件下載