VBA循环写入Excel单元格速度极慢，求优化方案

嘿，我太懂这种困扰了——逐行插入、选择单元格的VBA脚本跑起来慢到让人抓狂对吧？咱们直接上干货，从根源解决你的性能问题：

核心问题：频繁和Excel对象交互 #

你的代码里每一次Select、Insert、Copy都是在和Excel的对象模型做通信，这种单次调用的开销其实很大，循环几十上百次下来，总耗时就爆炸了。优化的核心就是减少交互次数，把多次操作合并成批量操作。

具体优化步骤 #

1. 关闭Excel的“实时反馈”功能
   每次插入行时，Excel会自动刷新屏幕、触发工作表事件、重新计算公式，这些都是隐形的性能杀手。在代码开头先把这些关掉，结束后再恢复：

   ' 关闭耗时功能
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   Application.Calculation = xlCalculationManual
   
   ' 你的核心代码...
   
   ' 恢复默认设置
   Application.ScreenUpdating = True
   Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
   

2. 彻底抛弃Select和Selection
   这是VBA性能优化的黄金法则之一——直接操作单元格/行对象，不要绕弯子选来选去。你原来的代码：

   Rows(startRow & ":" & startRow).Select
   Selection.Copy
   Rows(startRow + 1 & ":" & startRow + 1).Select
   Selection.Insert Shift:=xlDown
   

   可以简化成两行，完全不用选择：

   Rows(startRow).Copy
   Rows(startRow + 1).Insert Shift:=xlDown
   

3. 批量插入行，而不是逐行插
   如果要插入i-1行，别循环i-1次每次插1行，直接一次性插入所有需要的行：

   ' 假设要从startRow+1开始插入i-1行
   Dim totalInsertRows As Integer
   totalInsertRows = i - 1
   Rows(startRow + 1 & ":" & startRow + totalInsertRows).Insert Shift:=xlDown
   ' 然后把模板行一次性复制到所有新行
   Rows(startRow).Copy Destination:=Rows(startRow + 1 & ":" & startRow + totalInsertRows)
   

   这一步能把i-1次插入操作变成1次，性能提升非常明显。

4. 用数组批量写入数据/公式
   你后面要写入roomType(j)相关的内容，别逐单元格赋值，先把所有数据装进一个数组，再一次性写入到目标区域：

   ' 假设要写入到新行的B列，共i-1行
   Dim dataArr As Variant
   ReDim dataArr(1 To i-1, 1 To 1) ' 1列i-1行的数组
   
   For j = 0 To i-2
       dataArr(j+1, 1) = roomType(j) & "你的其他内容" ' 填充数组
   Next j
   
   ' 一次性写入到Excel
   Range("B" & startRow + 1 & ":B" & startRow + (i-1)).Value = dataArr
   

   数组操作是在内存里完成的，只需要和Excel做一次交互，比逐单元格写快几个数量级。

优化后的完整示例 #

把这些点整合起来，你的代码会变成这样（根据实际需求调整细节）：

Sub FastInsertAndFill()
    Dim startRow As Integer
    startRow = 5 ' 替换成你的起始行号
    Dim i As Integer
    i = 10 ' 替换成你的实际循环上限
    
    ' 关闭耗时功能
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 批量插入行
    Dim totalInsertRows As Integer
    totalInsertRows = i - 1
    Rows(startRow + 1 & ":" & startRow + totalInsertRows).Insert Shift:=xlDown
    ' 批量复制模板行
    Rows(startRow).Copy Destination:=Rows(startRow + 1 & ":" & startRow + totalInsertRows)
    
    ' 准备数据数组并批量写入
    Dim dataArr As Variant
    ReDim dataArr(1 To totalInsertRows, 1 To 1)
    Dim j As Integer
    For j = 0 To totalInsertRows - 1
        dataArr(j + 1, 1) = roomType(j) & "你的后续内容"
    Next j
    Range("A" & startRow + 1 & ":A" & startRow + totalInsertRows).Value = dataArr
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

按照这个思路改完，你会发现代码的执行速度提升至少一个数量级——亲测有效！

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