Excel批量插入行及复制数据的高效实现方案咨询

问题场景 #

处理65MB的Excel文件，需完成值查找、条件判断并向7个工作表插入行，参考数据表wsSrcREDW包含75k+行。现有VBA代码运行耗时超5分钟，经排查慢因集中在循环插入行环节，需更高效的实现方案。

原代码 #

Dim Curr() As String

For Each c In wsSrcREDW.Range("J2:J" & lrow1).Cells
    ReDim Preserve Curr(2 To c.Row)
    Curr(c.Row) = c.Value
Next c


Dim Entity() As String

For Each c In wsSrcREDW.Range("C2:C" & lrow1).Cells
    ReDim Preserve Entity(2 To c.Row)
    Entity(c.Row) = c.Value
Next c

Dim M9() As String

For Each c In wsSrcREDW.Range("F2:F" & lrow1).Cells
    ReDim Preserve M9(2 To c.Row)
    M9(c.Row) = c.Value
Next c


''' ECL Wback

Set wsECLWMBB = wbREDWMBB.Sheets("ECL WBack")
lrowECLWOrg = wsECLWMBB.Range("A" & Rows.Count).End(xlUp).Row

Dim I7() As String

For Each c In wsSrcREDW.Range("S2:S" & lrow1).Cells
    ReDim Preserve I7(2 To c.Row)
    I7(c.Row) = c.Value
Next c

For i = 2 To UBound(I7)
    Set c = wsECLWMBB.Range("B2:B" & lrowECLWOrg).Find(I7(i))
    If c Is Nothing And Entity(i) = "MIB" Then
        lrowECLW = wsECLWMBB.Range("A" & Rows.Count).End(xlUp).Row
        wsECLWMBB.Range("A" & (lrowECLW + 1)).EntireRow.Insert            
        wsECLWMBB.Range("A" & (lrowECLW + 1)).Value = M9(i)
        wsECLWMBB.Range("B" & (lrowECLW + 1)).Value = I7(i)
        wsECLWMBB.Range("C" & (lrowECLW + 1)).Value = Curr(i)
        wsECLWMBB.Range("D" & (lrowECLW + 1)).Formula = "=MID(B" & (lrowECLW + 1) & ",1,7)"
    End If
Next i

原代码低效原因 #

• 逐行插入操作：每次插入行都会触发Excel重绘、公式计算和内存重排，75k次循环中多次执行会累积巨大开销
• 重复查找：每次调用Range.Find都会遍历目标列，无缓存机制，查找效率极低
• 数组赋值冗余：逐个单元格读取并反复ReDim Preserve，每次扩容都要复制整个数组，耗时严重
• 重复获取最后一行：每次插入后都重新计算最后一行，增加不必要的IO操作

优化方案 #

核心优化思路

1. 用**字典（Dictionary）**存储目标表的查找值，将查找复杂度从O(n)降到O(1)
2. 批量收集待插入数据：先把所有符合条件的行数据存入数组，最后一次性插入到工作表
3. 一次性读取整列数据：直接将整列数据读取到数组，避免逐个单元格操作和反复扩容
4. 关闭Excel后台操作：临时关闭屏幕更新、自动计算等，减少中间环节的性能损耗

优化后的代码（以"ECL WBack"工作表为例）

Sub OptimizedInsertRows()
    Dim wsSrcREDW As Worksheet, wsECLWMBB As Worksheet
    Dim lrow1 As Long, lrowECLWOrg As Long
    Dim srcData As Variant, insertData As Variant
    Dim lookupDict As Object
    Dim i As Long, insertCount As Long
    
    ' 初始化对象
    Set wsSrcREDW = ThisWorkbook.Sheets("wsSrcREDW") ' 根据实际表名调整
    Set wsECLWMBB = wbREDWMBB.Sheets("ECL WBack")
    Set lookupDict = CreateObject("Scripting.Dictionary")
    
    ' 关闭Excel后台操作，提升速度
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    ' 1. 读取源表所有需要的数据到数组（一次性读取，避免逐单元格操作）
    lrow1 = wsSrcREDW.Range("J" & Rows.Count).End(xlUp).Row
    srcData = wsSrcREDW.Range("C2:S" & lrow1).Value ' 包含C、F、J、S列数据
    
    ' 2. 把目标表B列的值存入字典，用于快速查找
    lrowECLWOrg = wsECLWMBB.Range("B" & Rows.Count).End(xlUp).Row
    For i = 2 To lrowECLWOrg
        If Not lookupDict.Exists(wsECLWMBB.Cells(i, "B").Value) Then
            lookupDict.Add wsECLWMBB.Cells(i, "B").Value, True
        End If
    Next i
    
    ' 3. 遍历源数据，收集符合条件的待插入数据
    insertCount = 0
    ' 先预估数组大小，避免反复扩容
    ReDim insertData(1 To lrow1 - 1, 1 To 4) ' 4列：A、B、C、D
    
    For i = 1 To UBound(srcData)
        ' 条件：Entity是MIB，且目标表中不存在对应I7值
        If srcData(i, 1) = "MIB" And Not lookupDict.Exists(srcData(i, 17)) Then
            insertCount = insertCount + 1
            insertData(insertCount, 1) = srcData(i, 4) ' M9列（F列，对应srcData第4列）
            insertData(insertCount, 2) = srcData(i, 17) ' I7列（S列，对应srcData第17列）
            insertData(insertCount, 3) = srcData(i, 8) ' Curr列（J列，对应srcData第8列）
            ' D列公式先记录行号占位，后续统一替换
            insertData(insertCount, 4) = "=MID(B{ROW},1,7)"
        End If
    Next i
    
    ' 4. 批量插入数据到目标表
    If insertCount > 0 Then
        ' 调整数组到实际需要的大小
        ReDim Preserve insertData(1 To insertCount, 1 To 4)
        ' 获取目标表最后一行，一次性插入对应行数
        lrowECLWOrg = wsECLWMBB.Range("A" & Rows.Count).End(xlUp).Row
        wsECLWMBB.Range("A" & lrowECLWOrg + 1).Resize(insertCount, 4).Value = insertData
        
        ' 批量替换公式中的行号
        For i = lrowECLWOrg + 1 To lrowECLWOrg + insertCount
            wsECLWMBB.Cells(i, "D").Formula = Replace(wsECLWMBB.Cells(i, "D").Value, "{ROW}", i)
        Next i
    End If
    
    ' 恢复Excel后台操作
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
    ' 释放对象
    Set lookupDict = Nothing
    Set wsSrcREDW = Nothing
    Set wsECLWMBB = Nothing
End Sub

扩展到7个工作表的建议 #

• 把针对单个工作表的逻辑封装成独立的Sub过程，传入工作表名称、对应列映射等参数
• 统一在主过程中关闭/恢复Excel后台操作，避免重复执行
• 每个工作表单独创建字典和收集待插入数据，确保逻辑清晰

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