VBA子目录文件查找问题：无需完整路径及报错排查

问题分析与报错原因 #

你的代码出现**Type Mismatch（类型不匹配）**主要有以下几个核心原因：

1. Dir命令参数逻辑不匹配
   你第一个代码用InStr(file, "701000034955")实现的是文件名包含指定字符串的模糊匹配，但第二个代码里的Dir命令是Dir """ & f & ibox & """，这是精确匹配文件名。如果目标文件名只是包含该字符串而非完全等于它，Dir会找不到文件，导致stdout.readall返回空字符串，后续数组赋值时触发类型不匹配。

2. 空数组/无效元素的赋值问题
   当Dir无匹配结果时，Split空字符串会得到仅含空元素的数组。即使UBound(sn)+1计算为1，空元素转置后赋值给单元格时，可能触发隐性类型转换错误；另外Dir命令执行后会在输出末尾多一行空行，也会导致数组包含无效的空元素。

3. Transpose函数的长度限制
   旧版Excel中Application.Transpose对数组长度有上限（最多65536个元素），如果找到的文件数量超过这个阈值，也会引发类型不匹配。

修复现有Cmd方案的代码 #

调整Dir参数支持模糊匹配，并添加数组清理逻辑，避免无效赋值：

Sub Find_Files_Fixed()
    Dim f As String, ibox As String
    Dim sn As Variant, validCount As Integer
    Dim shellExec As Object
    
    f = "\\A\B\"
    ibox = "701000034955"
    
    ' 用通配符实现模糊匹配，和第一个代码的InStr逻辑对齐
    Set shellExec = CreateObject("wscript.shell").exec("cmd /c Dir """ & f & "*" & ibox & "*""" /s /a /b")
    sn = Split(shellExec.stdout.readall, vbCrLf)
    
    ' 清理数组末尾的空元素（Dir命令默认会多一行空行）
    validCount = UBound(sn)
    Do While validCount >= 0 And sn(validCount) = ""
        validCount = validCount - 1
    Loop
    
    ' 无匹配文件的情况处理
    If validCount < 0 Then
        MsgBox "未找到包含指定字符串的文件"
        Exit Sub
    End If
    ReDim Preserve sn(0 To validCount)
    
    ' 安全赋值到工作表
    Sheets("Sheet1").[A1].Resize(UBound(sn) + 1) = Application.Transpose(sn)
End Sub

更优的子目录文件查找方案 #

调用Cmd的方法依赖系统环境，稳定性不如VBA原生方案，推荐以下两种更可靠的实现：

方案1：FileSystemObject（FSO）递归查找

FSO是VBA原生的文件系统操作对象，代码可读性高，易于调试和扩展：

Sub FindFiles_WithFSO()
    Dim fso As Object, rootFolder As Object
    Dim targetStr As String, rootPath As String
    Dim ws As Worksheet, rowNum As Integer
    
    rootPath = "\\A\B\"
    targetStr = "701000034955"
    Set ws = Sheets("Sheet1")
    rowNum = 1
    ws.Cells.Clear ' 清空原有内容
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(rootPath) Then
        MsgBox "指定目录不存在！"
        Exit Sub
    End If
    
    ' 启动递归遍历
    Call SearchFiles(fso.GetFolder(rootPath), targetStr, ws, rowNum)
    
    MsgBox "查找完成，共找到" & rowNum - 1 & "个匹配文件"
End Sub

Private Sub SearchFiles(folder As Object, targetStr As String, ws As Worksheet, ByRef rowNum As Integer)
    Dim file As Object, subFolder As Object
    
    ' 遍历当前文件夹的文件
    For Each file In folder.Files
        If InStr(file.Name, targetStr) > 0 Then
            ws.Cells(rowNum, 1).Value = file.Path
            rowNum = rowNum + 1
        End If
    Next file
    
    ' 递归遍历子文件夹
    For Each subFolder In folder.SubFolders
        Call SearchFiles(subFolder, targetStr, ws, rowNum)
    Next subFolder
End Sub

方案2：Dir函数递归查找

和你最初的代码风格一致，无需额外引用对象，轻量高效：

Sub FindFiles_WithDir()
    Dim rootPath As String, targetStr As String
    Dim ws As Worksheet, rowNum As Integer
    
    rootPath = "\\A\B\"
    targetStr = "701000034955"
    Set ws = Sheets("Sheet1")
    rowNum = 1
    ws.Cells.Clear
    
    ' 确保路径末尾有反斜杠
    If Right(rootPath, 1) <> "\" Then rootPath = rootPath & "\"
    
    ' 启动递归查找
    Call DirRecursive(rootPath, targetStr, ws, rowNum)
    
    MsgBox "查找完成，共找到" & rowNum - 1 & "个匹配文件"
End Sub

Private Sub DirRecursive(folderPath As String, targetStr As String, ws As Worksheet, ByRef rowNum As Integer)
    Dim fileName As String, subFolder As String
    
    ' 遍历当前文件夹的所有文件
    fileName = Dir(folderPath & "*.*", vbNormal)
    Do While fileName <> ""
        If InStr(fileName, targetStr) > 0 Then
            ws.Cells(rowNum, 1).Value = folderPath & fileName
            rowNum = rowNum + 1
        End If
        fileName = Dir
    Loop
    
    ' 遍历子文件夹并递归
    subFolder = Dir(folderPath, vbDirectory)
    Do While subFolder <> ""
        ' 跳过当前目录和上级目录的标记
        If subFolder <> "." And subFolder <> ".." Then
            If (GetAttr(folderPath & subFolder) And vbDirectory) = vbDirectory Then
                Call DirRecursive(folderPath & subFolder & "\", targetStr, ws, rowNum)
            End If
        End If
        subFolder = Dir
    Loop
End Sub

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