优化低效VBA宏：解决大文件下查找替换与公式计算缓慢问题

我有两个结构近似的文件，一个约2万行，另一个约18万行。宏在大文件中运行卡顿严重，排查后发现耗时最长的是查找替换和FormulaR1C1公式写入操作。尝试用数组优化移除$符号时，耗时反而比直接用Sheet.Range.Replace更长，原代码如下：

' 原始替换$的代码
Dim ws As Worksheet
Dim lrow As Long
lrow = ws.Cells(Rows.Count, 4).End(xlUp).Row
ws.Range("BG:BG, BI:BI").Replace what:="$", Replacement:="", lookat:=xlPart

' 尝试优化的数组代码（实际更慢）
Dim Array1 As Variant
Set Array1 = ws.Range("BG2:BG" & lrow)
    For Each cell In Array1
        cell.value = Replace(cell.value, "$", "")
    Next cell
Dim Array2 As Variant
Set Array2 = ws.Range("BI2:BI" & lrow)
    For Each cell In Array2
        cell.value = Replace(cell.value, "$", "")
    Next cell

为什么数组循环比Range.Replace更慢？ #

你写的"数组代码"根本没用到数组的核心优势——只是把Range对象赋值给变量，本质还是逐单元格操作工作表。VBA性能瓶颈的核心是工作表IO远慢于内存操作，真正的数组优化是把数据读到内存数组，在内存中处理后一次性写回，大幅减少和工作表的交互次数。

优化后的$替换代码 #

Dim ws As Worksheet
Dim lrow As Long
Dim arrBG As Variant, arrBI As Variant
Dim i As Long

Set ws = ActiveSheet ' 替换为你的目标工作表
lrow = ws.Cells(Rows.Count, 4).End(xlUp).Row

' 将列数据批量读入内存数组
arrBG = ws.Range("BG2:BG" & lrow).Value
arrBI = ws.Range("BI2:BI" & lrow).Value

' 在内存中批量替换$
For i = LBound(arrBG, 1) To UBound(arrBG, 1)
    If Not IsEmpty(arrBG(i, 1)) Then
        arrBG(i, 1) = Replace(arrBG(i, 1), "$", "")
    End If
    If Not IsEmpty(arrBI(i, 1)) Then
        arrBI(i, 1) = Replace(arrBI(i, 1), "$", "")
    End If
Next i

' 一次性将结果写回工作表
ws.Range("BG2:BG" & lrow).Value = arrBG
ws.Range("BI2:BI" & lrow).Value = arrBI

FormulaR1C1的性能优化选择 #

公式写入的性能问题同样源于频繁的工作表交互，需分场景处理：

• 简单计算（拼接、加减乘除、基础IF）：用内存数组计算后写回，比写入公式再计算快得多，避免触发工作表计算引擎的额外开销。
• 复杂函数（如XLOOKUP）：跨表查询的数组实现需要自定义查找逻辑，若逻辑复杂，可先关闭自动计算，批量写入公式后再恢复，平衡开发效率和运行速度。

简单公式的数组实现示例 #

针对你给出的几个简单公式，改成内存数组计算：

Dim arrA As Variant, arrC As Variant, arrB As Variant
Dim arrQ As Variant, arrR As Variant, arrS As Variant, arrP As Variant
Dim arrU As Variant, arrV As Variant
Dim arrAX As Variant, arrAY As Variant
Dim i As Long

' 批量读取源数据到内存数组
arrA = ws.Range("A2:A" & lrow).Value
arrC = ws.Range("C2:C" & lrow).Value
arrB = ws.Range("B2:B" & lrow).Value ' 存储A-C拼接结果

arrQ = ws.Range("Q2:Q" & lrow).Value
arrR = ws.Range("R2:R" & lrow).Value
arrS = ws.Range("S2:S" & lrow).Value
arrP = ws.Range("P2:P" & lrow).Value ' 存储Q+R+S求和结果

arrU = ws.Range("U2:U" & lrow).Value
arrV = ws.Range("V2:V" & lrow).Value ' 存储除法计算结果

arrAX = ws.Range("AX2:AX" & lrow).Value
arrAY = ws.Range("AY2:AY" & lrow).Value ' 存储乘法计算结果

' 内存中循环计算
For i = LBound(arrA, 1) To UBound(arrA, 1)
    ' B列：A列值拼接"-"和C列值
    arrB(i, 1) = arrA(i, 1) & "-" & arrC(i, 1)
    
    ' P列：Q+R+S求和
    arrP(i, 1) = arrQ(i, 1) + arrR(i, 1) + arrS(i, 1)
    
    ' V列：U为0时返回0，否则返回B/U
    arrV(i, 1) = IIf(arrU(i, 1) = 0, 0, arrB(i, 1) / arrU(i, 1))
    
    ' AY列：AX*B
    arrAY(i, 1) = arrAX(i, 1) * arrB(i, 1)
Next i

' 一次性写回所有结果
ws.Range("B2:B" & lrow).Value = arrB
ws.Range("P2:P" & lrow).Value = arrP
ws.Range("V2:V" & lrow).Value = arrV
ws.Range("AY2:AY" & lrow).Value = arrAY

复杂函数（XLOOKUP）的数组实现示例 #

跨表查询的数组实现需要先将参考表数据读入内存，再循环匹配：

Dim baseWS As Worksheet
Dim baseArrKey As Variant, baseArrResult As Variant
Dim networkArrA As Variant, networkArrB As Variant
Dim i As Long, j As Long
Dim found As Boolean

Set baseWS = ThisWorkbook.Sheets("Base")
' 读取Base表的查询列（D列）和结果列（K列）
baseArrKey = baseWS.Range("D2:D" & baseWS.Cells(Rows.Count, 4).End(xlUp).Row).Value
baseArrResult = baseWS.Range("K2:K" & baseWS.Cells(Rows.Count, 11).End(xlUp).Row).Value

' 读取network表的查询列（A列）和结果列（B列）
networkArrA = wsnetwork.Range("A2:A" & lrow2).Value
networkArrB = wsnetwork.Range("B2:B" & lrow2).Value

' 内存中循环匹配
For i = LBound(networkArrA, 1) To UBound(networkArrA, 1)
    found = False
    For j = LBound(baseArrKey, 1) To UBound(baseArrKey, 1)
        If networkArrA(i, 1) = baseArrKey(j, 1) Then
            networkArrB(i, 1) = baseArrResult(j, 1)
            found = True
            Exit For
        End If
    Next j
    ' 未找到时返回#N/A，和XLOOKUP默认行为一致
    If Not found Then
        networkArrB(i, 1) = CVErr(xlErrNA)
    End If
Next i

' 写回匹配结果
wsnetwork.Range("B2:B" & lrow2).Value = networkArrB

通用性能优化开关 #

无论采用哪种方案，都要在宏的开头和结尾加上以下代码，减少不必要的工作表刷新和计算：

' 宏开头：关闭不必要的功能
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

' 宏结尾：恢复默认设置
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

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