VBA遍历列出含OLDIES的文件/文件夹 修复栈溢出报错

原代码触发栈空间不足的核心原因是递归逻辑错误：

• 递归调用ListOLDIES时未传入子文件夹路径，每次调用都会重新从配置的根目录开始遍历，形成无限递归，直接耗尽栈内存
• 其余逻辑缺陷：匹配规则未限定为文件/文件夹名称、未匹配要求的OLDIES-关键字、路径拆分逻辑在文件名含.时会出错、未处理文件夹类型条目、输出未按要求分三列。

Sub ListOLDIES()
    Dim FSO As Object
    Dim rootFolder As Object
    Dim startRow As Long
    ' 可修改为实际需要遍历的根目录路径
    Const SCAN_PATH As String = "C:\Desktop\"
    
    ' 初始化表格表头
    startRow = 2
    ActiveSheet.Cells(1, 1) = "Name"
    ActiveSheet.Cells(1, 2) = "Location"
    ActiveSheet.Cells(1, 3) = "Extension"
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(SCAN_PATH) Then
        MsgBox "配置的扫描路径不存在，请检查", vbExclamation
        Exit Sub
    End If
    Set rootFolder = FSO.GetFolder(SCAN_PATH)
    
    ' 执行递归遍历
    Call ScanSingleFolder(rootFolder, startRow)
    
    ' 收尾
    ActiveSheet.Columns("A:C").AutoFit
    MsgBox "遍历完成，共匹配到 " & startRow - 2 & " 条结果", vbInformation
    Set rootFolder = Nothing
    Set FSO = Nothing
End Sub

Sub ScanSingleFolder(currentFolder As Object, ByRef writeRow As Long)
    Dim subFolder As Object
    Dim scanFile As Object
    Dim dotPos As Long
    
    ' 匹配当前文件夹自身
    If InStr(1, currentFolder.Name, "OLDIES-", vbTextCompare) > 0 Then
        ActiveSheet.Cells(writeRow, 1) = currentFolder.Name
        ActiveSheet.Cells(writeRow, 2) = currentFolder.ParentFolder.Path & "\"
        ActiveSheet.Cells(writeRow, 3) = "Folder"
        writeRow = writeRow + 1
    End If
    
    ' 遍历当前目录下所有文件
    For Each scanFile In currentFolder.Files
        If InStr(1, scanFile.Name, "OLDIES-", vbTextCompare) > 0 Then
            dotPos = InStrRev(scanFile.Name, ".")
            ' 兼容无后缀、文件名带多个.的场景
            If dotPos > 0 Then
                ActiveSheet.Cells(writeRow, 1) = Left(scanFile.Name, dotPos - 1)
                ActiveSheet.Cells(writeRow, 3) = LCase(Mid(scanFile.Name, dotPos))
            Else
                ActiveSheet.Cells(writeRow, 1) = scanFile.Name
                ActiveSheet.Cells(writeRow, 3) = ""
            End If
            ActiveSheet.Cells(writeRow, 2) = currentFolder.Path & "\"
            writeRow = writeRow + 1
        End If
    Next
    
    ' 递归遍历子文件夹，跳过无权限访问的系统目录
    For Each subFolder In currentFolder.SubFolders
        On Error Resume Next
        Call ScanSingleFolder(subFolder, writeRow)
        On Error GoTo 0
    Next
End Sub

• 修改代码中SCAN_PATH常量的值为你实际需要扫描的根目录路径即可运行
• 匹配规则不区分大小写，只要文件/文件夹名称包含OLDIES-字符串就会被收录
• 遍历过程会自动跳过无权限访问的系统文件夹，不会因权限问题中断
• 结果按三列输出：第一列为文件/文件夹名称，第二列为所在目录路径，第三列文件夹固定标记为Folder，文件显示带.的后缀名
• 运行完成后会自动调整列宽，弹出匹配结果总数提示

内容的提问来源于stack exchange，提问作者mdashed