VBA遍历文件夹文件异常：重复选同文件/通配符Dir为空

原代码核心问题 #

1. 文件夹选择错误：使用Application.GetOpenFilename()选择的是单个文件，而非文件夹，导致Dir无法遍历该文件夹下的文件。
2. Dir函数用法错误：传入Dir的参数是文件路径而非文件夹路径，无法获取正确的文件列表，循环始终重复处理同一个文件。
3. 重复打开文件：多次调用Workbooks.Open(OpenFolder)重复打开同一个文件，未关闭已打开的文件，造成资源浪费且逻辑混乱。
4. 对象引用不规范：大量使用Select/Activate操作，容易引发错误，且代码可读性差。
5. 工作表存在性判断错误：直接Set WS = Sheets("Type A")会在工作表不存在时报错，未做错误处理。
6. Find方法使用错误：Find(...).Activate不能直接赋值给Boolean变量，应判断Find返回的对象是否为Nothing。
7. 未递归处理子文件夹：原代码仅处理当前文件夹，未遍历子目录中的文件。

修正后的完整代码 #

Sub CheckAllExcelFiles()
    Dim rootFolder As String
    Dim resWB As Workbook
    Dim resWS As Worksheet
    Dim nextRow As Long
    
    ' 设置结果工作簿和工作表
    Set resWB = Workbooks("Macro for file opener")
    Set resWS = resWB.Sheets("Result")
    
    ' 选择目标文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            rootFolder = .SelectedItems(1)
            If Right(rootFolder, 1) <> "\" Then rootFolder = rootFolder & "\"
        Else
            MsgBox "未选择文件夹，程序退出。"
            Exit Sub
        End If
    End With
    
    ' 开始遍历文件夹（含子文件夹）
    TraverseFolder rootFolder, resWS
    MsgBox "文件检查完成！"
End Sub

' 递归遍历文件夹及其子文件夹
Sub TraverseFolder(folderPath As String, resWS As Worksheet)
    Dim fileName As String
    Dim subFolderName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim foundCode As Boolean
    Dim foundMissingPart As Boolean
    Dim foundNonBuildable As Boolean
    Dim nextRow As Long
    
    ' 获取当前文件夹下的Excel文件
    fileName = Dir(folderPath & "*.xlsx", vbNormal)
    Do While fileName <> ""
        ' 打开文件
        Set wb = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
        foundCode = False
        foundMissingPart = False
        foundNonBuildable = False
        
        ' 检查"Type A"工作表
        On Error Resume Next
        Set ws = wb.Sheets("Type A")
        On Error GoTo 0
        If Not ws Is Nothing Then
            ' 查找"code"
            If Not ws.Cells.Find(What:="code", LookIn:=xlFormulas2, LookAt:=xlWhole, MatchCase:=False) Is Nothing Then
                foundCode = True
            End If
            ' 查找"Missing part"
            If Not ws.Cells.Find(What:="Missing part", LookIn:=xlFormulas2, LookAt:=xlWhole, MatchCase:=False) Is Nothing Then
                foundMissingPart = True
            End If
        End If
        
        ' 检查"Chart"工作表
        On Error Resume Next
        Set ws = wb.Sheets("Chart")
        On Error GoTo 0
        If Not ws Is Nothing Then
            ' 查找"Non-Buildable Usage"
            If Not ws.Cells.Find(What:="Non-Buildable Usage", LookIn:=xlFormulas2, LookAt:=xlWhole, MatchCase:=False) Is Nothing Then
                foundNonBuildable = True
            End If
        End If
        
        ' 写入结果到工作表
        nextRow = resWS.Cells(resWS.Rows.Count, "A").End(xlUp).Row + 1
        resWS.Cells(nextRow, "A").Value = folderPath & fileName
        resWS.Cells(nextRow, "B").Value = IIf(foundCode, "code exist", IIf(ws Is Nothing, "file not exist", "code not exist"))
        resWS.Cells(nextRow, "C").Value = IIf(foundMissingPart, "Missing part exist", IIf(ws Is Nothing, "file not exist", "Missing part not exist"))
        resWS.Cells(nextRow, "D").Value = IIf(foundNonBuildable, "Non break exist", IIf(ws Is Nothing, "file not exist", "Non break not exist"))
        
        ' 关闭文件，不保存
        wb.Close SaveChanges:=False
        Set wb = Nothing
        
        ' 获取下一个文件
        fileName = Dir()
    Loop
    
    ' 递归处理子文件夹
    subFolderName = Dir(folderPath, vbDirectory)
    Do While subFolderName <> ""
        ' 跳过当前文件夹和上级文件夹标记
        If subFolderName <> "." And subFolderName <> ".." Then
            ' 判断是否为文件夹
            If (GetAttr(folderPath & subFolderName) And vbDirectory) = vbDirectory Then
                TraverseFolder folderPath & subFolderName & "\", resWS
            End If
        End If
        subFolderName = Dir()
    Loop
End Sub

关键改进说明 #

• 正确选择文件夹：使用msoFileDialogFolderPicker对话框让用户选择文件夹，而非单个文件。
• 递归遍历子文件夹：通过自定义TraverseFolder子程序，递归处理所有子目录中的文件。
• 规范Dir使用：指定Excel文件通配符*.xlsx，分别获取文件和子文件夹列表。
• 避免重复操作：每个文件仅打开一次，处理完成后立即关闭，释放资源。
• 取消Select/Activate：直接引用工作簿、工作表和单元格对象，避免激活操作带来的错误。
• 正确判断对象存在性：通过On Error Resume Next结合Is Nothing判断工作表是否存在，通过Find返回对象是否为Nothing判断内容是否存在。
• 优化结果写入：直接计算结果工作表的下一行，避免多次End(xlDown)操作，提升效率。

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