如何进一步加速这段VBA代码？已优化数组与避免Select仍不够快

核心问题定位 #

原代码的最大性能瓶颈是循环内反复读写工作表，每次循环都执行Hoja7.Range("A9:IL9") = ...和读取Hoja7.Cells(30,2)，工作表IO操作的速度比内存数组操作慢数百倍，这是导致运行慢的根本原因。以下是针对性优化方案：

1. 禁用不必要的Excel交互功能 #

在代码开头添加以下设置，避免循环中频繁刷新屏幕、触发事件或自动计算：

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual ' 若依赖公式计算，批量处理后再恢复

代码结尾务必恢复这些设置（建议加错误处理，防止异常导致设置无法恢复）：

Cleanup:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub
ErrorHandler:
    MsgBox "错误: " & Err.Description
    Resume Cleanup

2. 批量处理工作表IO，避免循环内逐行读写 #

把循环内的逐行写入/读取改成一次性批量操作：

• 一次性将整个arr数组写入Hoja7的连续区域（从A9开始）
• 手动触发一次计算，让Hoja7的公式生成所有结果
• 一次性读取所有计算结果，回写到arr的最后一列

示例代码片段：

' 一次性写入所有行到Hoja7
Hoja7.Range("A9").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

' 触发计算（如果Hoja7用了公式）
Hoja7.Calculate

' 一次性读取所有B30对应行的结果（需根据实际计算逻辑调整读取区域）
Dim resultsArr As Variant
resultsArr = Hoja7.Range("B30").Resize(UBound(arr, 1)).Value

' 将结果回写到arr的最后一列
Dim t As Long
For t = 1 To UBound(arr, 1)
    arr(t, UBound(arr, 2)) = resultsArr(t, 1)
    Application.StatusBar = "Simulación Nro " & t
Next t

3. 修复代码语法错误 #

原代码中存在乱码行：Dim valor ra"}/Loop太 requiring symmetry七个迷住份的和平絮语，必须删除并替换为正确的变量声明：

Dim valor As Long

4. 简化数组最终写入操作 #

原代码用WorksheetFunction.Index提取最后一列，可直接用数组赋值简化：

' 提取arr的最后一列并写入Hoja5
Hoja5.Range("IP51").Resize(UBound(arr, 1), 1).Value = Application.Index(arr, 0, UBound(arr, 2))

优化后完整代码示例 #

Sub Operation()
    Dim t As Long
    Dim valor As Long
    Dim arr As Variant
    Dim resultsArr As Variant
    
    ' 禁用Excel交互功能
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    On Error GoTo ErrorHandler
    
    valor = Worksheets("Datos").Range("E24").Value
    arr = Hoja5.Cells(valor, "A").CurrentRegion
    
    ' 批量写入arr到Hoja7
    Hoja7.Range("A9").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    ' 触发计算
    Hoja7.Calculate
    ' 批量读取计算结果（需根据Hoja7实际逻辑调整区域）
    resultsArr = Hoja7.Range("B30").Resize(UBound(arr, 1)).Value
    
    ' 更新arr的最后一列
    For t = 1 To UBound(arr, 1)
        arr(t, UBound(arr, 2)) = resultsArr(t, 1)
        Application.StatusBar = "Simulación Nro " & t
    Next t
    
    ' 写入最终结果到Hoja5
    Hoja5.Range("IP51").Resize(UBound(arr, 1), 1).Value = Application.Index(arr, 0, UBound(arr, 2))

Cleanup:
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub

ErrorHandler:
    MsgBox "执行错误: " & Err.Description
    Resume Cleanup
End Sub

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