Excel VBA技术求助：隐藏工作表后数据异常、代码优化及批量提速

问题1：隐藏工作表后搜索失效修复 #

原代码依赖ActiveSheet/sh.Activate操作，隐藏工作表无法激活，导致搜索跳转至宏文件。核心修复逻辑：完全抛弃Active系列对象，直接通过工作表对象引用操作：

• 遍历工作表时直接使用sh对象获取属性（如工作表名sh.Name），无需激活
• 所有查找操作直接绑定到sh.Cells，不依赖激活状态

问题2：写入结果准确性加固 #

原代码未明确绑定结果写入的工作簿，易因当前激活工作簿变化导致写入错误。修复方式：明确指定宏所在工作簿：

• 用ThisWorkbook.Sheets("Sheet4")绑定结果工作表，确保所有写入操作都指向宏文件内的Sheet4
• 所有读取搜索关键词的操作也绑定ThisWorkbook.Sheets("Sheet1")，避免跨工作簿误读

问题3：10000个文件快速搜索优化 #

针对大量文件，通过以下手段大幅提升效率：

• 禁用Excel界面更新、事件触发和自动计算，减少后台开销
• 以不可见模式打开目标工作簿，避免窗口切换耗时
• 用数组批量存储结果，最后一次性写入工作表（比逐单元格写入快10倍以上）
• 添加错误捕获，单个文件打开失败不中断整个流程
• 优化查找循环逻辑，避免死循环

完整优化后代码 #

Sub SearchMultipleWorkbooks()
    ' 开启高速模式：禁用不必要的Excel功能
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim cl As Range
    Dim FirstFound As String
    Dim SearchString As String
    Dim lastRowFiles As Long
    Dim resultArr() As Variant
    Dim arrIndex As Integer
    Dim resultRow As Long
    
    ' 绑定宏工作簿内的结果表与搜索关键词
    Dim resultSheet As Worksheet
    Set resultSheet = ThisWorkbook.Sheets("Sheet4")
    SearchString = ThisWorkbook.Sheets("Sheet1").Cells(6, 8).Value
    
    ' 获取文件列表的最后一行
    lastRowFiles = resultSheet.Range("A" & Rows.Count).End(xlUp).Row
    
    ' 预分配结果数组（假设每个文件最多100个匹配项，可按需调整）
    ReDim resultArr(1 To (lastRowFiles - 1) * 100, 1 To 4)
    arrIndex = 0
    
    ' 遍历所有目标文件
    For resultRow = 2 To lastRowFiles
        ' 捕获文件打开错误（如文件不存在、权限问题）
        On Error Resume Next
        Set wb = Workbooks.Open(resultSheet.Cells(resultRow, 2).Value, Visible:=False)
        On Error GoTo 0
        
        If Not wb Is Nothing Then
            ' 遍历当前工作簿所有工作表（包括隐藏表）
            For Each sh In wb.Worksheets
                ' 查找第一个匹配项
                Set cl = sh.Cells.Find(What:=SearchString, After:=sh.Cells(1, 1), _
                    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
                
                If Not cl Is Nothing Then
                    FirstFound = cl.Address
                    ' 循环查找所有匹配项
                    Do
                        arrIndex = arrIndex + 1
                        resultArr(arrIndex, 1) = resultSheet.Cells(resultRow, 1).Value ' 工作簿名
                        resultArr(arrIndex, 2) = sh.Name ' 工作表名
                        resultArr(arrIndex, 3) = cl.Address ' 单元格地址
                        resultArr(arrIndex, 4) = cl.Value ' 单元格值
                        
                        Set cl = sh.Cells.FindNext(After:=cl)
                    ' 防止FindNext返回空值或回到起点导致死循环
                    Loop Until cl Is Nothing Or cl.Address = FirstFound
                End If
            Next sh
            
            ' 关闭工作簿，不保存更改
            wb.Close SaveChanges:=False
            Set wb = Nothing
        End If
    Next resultRow
    
    ' 批量写入结果到工作表
    If arrIndex > 0 Then
        resultSheet.Range("C2").Resize(arrIndex, 4).Value = resultArr
    End If
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

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