修改VBA代码实现批量遍历单元格值搜索指定文件夹Excel文件

问题背景 #

需要修改现有VBA代码，实现遍历工作表中指定单元格区域的数值，批量搜索指定文件夹内格式统一的Excel文件，匹配对应信息后提取相关数据。原代码仅支持单个数值搜索，自行添加循环和修改搜索值引用后未生效。

原代码 #

Sub SearchFolders()
    Dim fso As Object
    Dim fld As Object
    Dim strSearch As String
    Dim strPath As String
    Dim strFile As String
    Dim wOut As Worksheet
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim lRow As Long
    Dim rFound As Range
    Dim strFirstAddress As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    strPath = "J:\FILE_PATH\Work Center Rounting Data"
    strSearch = "900491787"

    Do Until IsEmpty(ActiveCell)

        Set wOut = ActiveWorkbook.Worksheets("Material # Info Search")
        lRow = 1
        With wOut
        .Cells(lRow, 1) = "Workbook"
        .Cells(lRow, 2) = "Worksheet"
        .Cells(lRow, 3) = "Cell"
        .Cells(lRow, 4) = "Text in Cell"
        .Cells(lRow, 5) = "Set Up Time"
        .Cells(lRow, 6) = "Production Time"
        
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fld = fso.GetFolder(strPath)
    
        strFile = Dir(strPath & "\*.xls*")
        Do While strFile <> ""
            Set wbk = Workbooks.Open _
              (Filename:=strPath & "\" & strFile, _
              UpdateLinks:=0, _
              ReadOnly:=True, _
              AddToMRU:=False)
    
            For Each wks In wbk.Worksheets
                Set rFound = wks.UsedRange.Find(strSearch)
                
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                End If
                Do
                    If rFound Is Nothing Then
                        Exit Do
                    Else
                        lRow = lRow + 1
                       .Cells(lRow, 1) = wbk.Name
                        .Cells(lRow, 2) = wks.Name
                        .Cells(lRow, 3) = rFound.Address
                        .Cells(lRow, 4) = rFound.Value
                        .Cells(lRow, 5) = rFound.Offset(, 11).Value
                        .Cells(lRow, 6) = rFound.Offset(, 13).Value
                    End If
                    Set rFound = wks.Cells.FindNext(After:=rFound)
                Loop While strFirstAddress <> rFound.Address
            Next
    
            wbk.Close (False)
            strFile = Dir
        Loop
        .Columns("A:F").EntireColumn.AutoFit
    End With
    MsgBox "Done"

ExitHandler:
    Set wOut = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
    
    ActiveCell.Offset(1, 0).Select
    Loop
End Sub

尝试添加的循环代码 #

Sub Test2()
    ' Select cell A2, *first line of data*.
    Range("A2").Select
    ' Set Do loop to stop when an empty cell is reached.
    Do Until IsEmpty(ActiveCell)
    ' Insert your code here.
    ' Step down 1 row from present location.
    ActiveCell.Offset(1, 0).Select
    Loop
End Sub

修改后的完整可行代码 #

Sub BatchSearchFolders()
    Dim fso As Object
    Dim strPath As String
    Dim strFile As String
    Dim wOut As Worksheet
    Dim wbk As Workbook
    Dim wks As Worksheet
    Dim lRow As Long
    Dim rFound As Range
    Dim strFirstAddress As String
    Dim searchCell As Range
    Dim strSearch As String

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    ' 指定搜索文件夹路径
    strPath = "J:\FILE_PATH\Work Center Rounting Data"
    ' 指定输出工作表
    Set wOut = ActiveWorkbook.Worksheets("Material # Info Search")
    
    ' 初始化输出表头（仅执行一次）
    lRow = 1
    With wOut
        .Cells(lRow, 1) = "Workbook"
        .Cells(lRow, 2) = "Worksheet"
        .Cells(lRow, 3) = "Cell"
        .Cells(lRow, 4) = "Text in Cell"
        .Cells(lRow, 5) = "Set Up Time"
        .Cells(lRow, 6) = "Production Time"
    End With

    ' 遍历A列从A2开始的非空单元格（可根据实际需求修改列和起始行）
    Set searchCell = ActiveSheet.Range("A2")
    Do Until IsEmpty(searchCell.Value)
        strSearch = searchCell.Value
        
        ' 获取当前输出表的最后一行，避免覆盖已有数据
        lRow = wOut.Cells(wOut.Rows.Count, "A").End(xlUp).Row
        
        ' 遍历目标文件夹中的Excel文件
        strFile = Dir(strPath & "\*.xls*")
        Do While strFile <> ""
            Set wbk = Workbooks.Open( _
                Filename:=strPath & "\" & strFile, _
                UpdateLinks:=0, _
                ReadOnly:=True, _
                AddToMRU:=False)
    
            For Each wks In wbk.Worksheets
                Set rFound = wks.UsedRange.Find( _
                    What:=strSearch, _
                    LookIn:=xlValues, _
                    LookAt:=xlWhole, _
                    MatchCase:=False)
                
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                    Do
                        lRow = lRow + 1
                        With wOut
                            .Cells(lRow, 1) = wbk.Name
                            .Cells(lRow, 2) = wks.Name
                            .Cells(lRow, 3) = rFound.Address
                            .Cells(lRow, 4) = rFound.Value
                            .Cells(lRow, 5) = rFound.Offset(, 11).Value
                            .Cells(lRow, 6) = rFound.Offset(, 13).Value
                        End With
                        Set rFound = wks.Cells.FindNext(After:=rFound)
                    Loop While Not rFound Is Nothing And rFound.Address <> strFirstAddress
                End If
            Next wks
    
            wbk.Close (False)
            strFile = Dir
        Loop
        
        ' 移动到下一个搜索单元格
        Set searchCell = searchCell.Offset(1, 0)
    Loop

    ' 自动调整输出列宽
    wOut.Columns("A:F").EntireColumn.AutoFit
    MsgBox "批量搜索完成！"

ExitHandler:
    Set wOut = Nothing
    Set wks = Nothing
    Set wbk = Nothing
    Set fso = Nothing
    Set searchCell = Nothing
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox "错误信息：" & Err.Description, vbExclamation
    Resume ExitHandler
End Sub

关键修改说明 #

• 优化循环结构：将遍历搜索值的循环放在最外层，避免重复初始化表头和重复遍历文件夹（原代码每次循环都重新遍历所有文件，效率极低）
• 动态获取搜索值：直接通过单元格对象引用获取值，摒弃Select操作，提升代码稳定性和执行效率
• 表头仅初始化一次：避免每次搜索都覆盖原有表头和数据
• 修正Find方法参数：添加LookIn:=xlValues、LookAt:=xlWhole等明确参数，避免因默认设置导致的匹配错误
• 正确处理FindNext循环：完善循环终止条件，防止无限循环或遗漏匹配项
• 保留历史数据：每次搜索前获取输出表的最后一行，新数据追加到现有数据下方

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