如何优化Excel VBA插入行宏以提升执行效率？

你当前的问题是循环调用vdc_InsertRow_Inventory插入100行时耗时过长，核心原因是逐行插入+重复触发Excel的重算/刷新，以下是具体优化方案：

核心优化点 #

1. 关闭Excel后台耗时操作 #

在宏执行前关闭自动重算、屏幕刷新、事件触发，避免每次操作都触发Excel的后台处理，执行完成后再恢复原设置：

' 保存原设置
Dim calcMode As XlCalculation
Dim screenUpdating As Boolean
Dim enableEvents As Boolean

calcMode = Application.Calculation
screenUpdating = Application.ScreenUpdating
enableEvents = Application.EnableEvents

' 关闭耗时功能
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

执行完核心逻辑后恢复：

' 恢复原设置
Application.Calculation = calcMode
Application.ScreenUpdating = screenUpdating
Application.EnableEvents = enableEvents

2. 一次性插入所有需要的行数 #

原来的循环逐行插入改成一次性插入指定行数，大幅减少Excel的行插入开销：

' 获取插入行数（替代原第一个宏的输入逻辑）
Dim rowCount As Long
rowCount = InputBox("请输入需要插入的行数：")
If rowCount <= 0 Then Exit Sub

With Worksheets("INVENTORY")
    ' 一次性插入rowCount行
    .Range("B8").Resize(rowCount).EntireRow.Insert
    ' 获取新插入的行范围
    Dim targetRange As Range
    Set targetRange = .Range("B8").Resize(rowCount).EntireRow
End With

3. 批量设置值和公式 #

将逐行设置公式的操作改成批量填充，利用Excel的批量赋值特性，避免重复计算：

With targetRange
    ' 清空B5:AI5（若只需清空一次，移到插入操作前即可）
    Worksheets("INVENTORY").Range("B5:AI5").ClearContents
    
    ' PRICING字段：批量设置C列值
    .Columns("C").Value = "Not Started"
    
    ' EXPENSES字段：批量设置公式
    .Columns("P").Formula = "=XLOOKUP(1,(LOOKUP2!$B$7:$B$100=H@) * (LOOKUP2!$C$7:$C$100=I@) * (LOOKUP2!$D$7:$D$100=J@) * (LOOKUP2!$E$7:$E$100=K@),LOOKUP2!$H$7:$H$100,0)"
    .Columns("Q").Formula = "=SUPPLIES!$E$12"
    
    ' SHIPPING字段：批量设置公式
    .Columns("S").Formula = "=XLOOKUP($R@, SHIP!$H$7:$H$938, SHIP!$I$7:$I$938,"""")"
    .Columns("U").Formula = "=XLOOKUP($T@, SHIP!$C$7:$C$41, SHIP!$F$7:$F$41,"""")"
    
    ' FEES字段：批量设置公式（修复原公式的语法错误）
    .Columns("X").Formula = "=FEES!$C$4*($D@+$E@+$F@)"
    .Columns("Y").Formula = "=IF($C@=""Not Started"",0,IF([@Price]+[@Ship]>9.99,FEES!$C$6,FEES!$C$5))"
    .Columns("Z").Formula = "=IF(COUNTIF($C23:$C$52,""Active"")>250,FEES!$C$8,FEES!$C$7)"
    .Columns("AB").Formula = "=$F@"
    
    ' GRADING字段：批量设置公式
    .Columns("AF").Formula = "=IF(AC@>0,GRADING!$D$15,0)"
End With

注意：原代码中Y8、Z8的公式存在语法错误（引号不匹配、括号缺失），已在上方修正，错误公式会导致Excel反复计算异常，也是耗时原因之一。

4. 删除不必要的Select操作 #

原代码中的Range("B5:AI5").Select+Selection.ClearContents可直接改为Range("B5:AI5").ClearContents，减少界面交互开销。

完整优化后的宏代码 #

将原两个宏合并为一个，一次性完成所有插入和赋值操作：

Sub vdc_BulkInsertRows_Inventory()
    ' 保存Excel原设置
    Dim calcMode As XlCalculation
    Dim screenUpdating As Boolean
    Dim enableEvents As Boolean
    calcMode = Application.Calculation
    screenUpdating = Application.ScreenUpdating
    enableEvents = Application.EnableEvents
    
    ' 关闭耗时功能
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error GoTo Cleanup ' 出错时自动恢复原设置
    
    ' 获取插入行数
    Dim rowCount As Long
    rowCount = InputBox("请输入需要插入的行数：")
    If rowCount <= 0 Then GoTo Cleanup
    
    Dim wsInventory As Worksheet
    Set wsInventory = Worksheets("INVENTORY")
    
    ' 一次性插入指定行数
    wsInventory.Range("B8").Resize(rowCount).EntireRow.Insert
    Dim targetRows As Range
    Set targetRows = wsInventory.Range("B8").Resize(rowCount).EntireRow
    
    ' 清空B5:AI5
    wsInventory.Range("B5:AI5").ClearContents
    
    ' 批量设置所有字段的值和公式
    With targetRows
        ' PRICING
        .Columns("C").Value = "Not Started"
        
        ' EXPENSES
        .Columns("P").Formula = "=XLOOKUP(1,(LOOKUP2!$B$7:$B$100=H@) * (LOOKUP2!$C$7:$C$100=I@) * (LOOKUP2!$D$7:$D$100=J@) * (LOOKUP2!$E$7:$E$100=K@),LOOKUP2!$H$7:$H$100,0)"
        .Columns("Q").Formula = "=SUPPLIES!$E$12"
        
        ' SHIPPING
        .Columns("S").Formula = "=XLOOKUP($R@, SHIP!$H$7:$H$938, SHIP!$I$7:$I$938,"""")"
        .Columns("U").Formula = "=XLOOKUP($T@, SHIP!$C$7:$C$41, SHIP!$F$7:$F$41,"""")"
        
        ' FEES（修复语法错误）
        .Columns("X").Formula = "=FEES!$C$4*($D@+$E@+$F@)"
        .Columns("Y").Formula = "=IF($C@=""Not Started"",0,IF([@Price]+[@Ship]>9.99,FEES!$C$6,FEES!$C$5))"
        .Columns("Z").Formula = "=IF(COUNTIF($C23:$C$52,""Active"")>250,FEES!$C$8,FEES!$C$7)"
        .Columns("AB").Formula = "=$F@"
        
        ' GRADING
        .Columns("AF").Formula = "=IF(AC@>0,GRADING!$D$15,0)"
    End With
    
    ' 滚动到指定位置
    ActiveWindow.ScrollColumn = 1
    wsInventory.Range("B8").Select
    
Cleanup:
    ' 恢复Excel原设置
    Application.Calculation = calcMode
    Application.ScreenUpdating = screenUpdating
    Application.EnableEvents = enableEvents
    If Err.Number <> 0 Then MsgBox "执行出错：" & Err.Description, vbCritical
End Sub

优化效果说明 #

• 原循环逐行操作会触发100次Excel重算、屏幕刷新，优化后仅触发1次，耗时可降低90%以上。
• 批量操作减少了Excel内部交互开销，避免重复劳动。
• 修复公式错误，消除了不必要的计算异常和报错。

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