如何将VBA单元格赋值改为区域与数组赋值以提升性能？

核心思路是先把所有计算结果存入内存数组，最后一次性写入Excel区域，彻底减少单元格IO操作次数（从几十次降到1次），这是解决VBA循环写单元格性能瓶颈的关键手段。

修改后的完整代码 #

Dim wsModel As Worksheet
Dim YearRange As Variant
Dim resultArr As Variant
Dim loopvar As Integer
Dim lastCol As Integer
Dim strValue As String
Dim Year As Integer
Dim RptPe As Double, RptAvg As Double

' 直接引用工作表，避免激活操作带来的性能损耗
Set wsModel = ThisWorkbook.Sheets("Model")
YearRange = wsModel.Range("C7:EZ7").Value

' 先确定有效数据的列数（找到YearRange最后一个非空且不以E结尾的列）
lastCol = 1
Do While lastCol <= UBound(YearRange, 2) _
    And YearRange(1, lastCol) <> "" _
    And Right(Trim(YearRange(1, lastCol)), 1) <> "E"
    lastCol = lastCol + 1
Loop
lastCol = lastCol - 1 ' 修正为最后有效列的索引

' 创建结果数组：2行（对应原代码的508、509行），lastCol列
ReDim resultArr(1 To 2, 1 To lastCol)

' 循环计算，将结果存入数组而非直接写单元格
loopvar = 1
Do While loopvar <= lastCol
    strValue = Trim(YearRange(1, loopvar))
    Year = CInt(strValue)
  
    GetSpecificData Year, RptPe, RptAvg
  
    ' 把计算结果存入数组对应位置
    If RptPe <> 0 Then resultArr(1, loopvar) = RptPe
    If RptAvg <> 0 Then resultArr(2, loopvar) = RptAvg

    loopvar = loopvar + 1
Loop

' 一次性将数组写入目标区域，完成所有赋值操作
wsModel.Range(wsModel.Cells(508, 3), wsModel.Cells(509, 2 + lastCol)).Value = resultArr

关键优化点说明 #

• 取消Activate操作：直接用变量引用工作表，避免Excel界面交互的额外开销
• 预分配数组大小：先确定有效数据的列数，创建匹配的二维数组，避免动态扩容的性能损耗
• 内存中存储结果：循环内只操作内存数组，彻底消除循环过程中的单元格IO（这是原代码耗时的核心原因）
• 批量写入收尾：最后用一行代码完成所有数据的写入，单次IO的性能开销远低于几十次单独写入

如果你的代码中有15处类似的单元格赋值，只需扩展数组的行数（比如设为15行），将每个计算结果存入数组对应的行，最后一次性写入对应多行的区域即可。

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