如何优化VBA代码以缩短Excel空行删除的运行时间？

原代码问题分析 #

1. 逻辑偏差：原代码判断的是A列空值行，但需求是保留H列值不为0的行，核心判断条件不匹配
2. 效率瓶颈：逐行循环删除是Excel VBA中最慢的操作之一，即使关闭了屏幕更新等设置，多次行删除仍会触发工作表内部重计算和结构调整，导致耗时5-15分钟

两种高效优化方案 #

方案1：筛选批量删除法（最简单高效） #

利用Excel原生筛选功能，一次性选中所有H列值为0的行并批量删除，4000行数据可在几秒内完成。

Sub KeepNonZeroHRows_Filter()
    Dim ws As Worksheet
    Dim lastRow As Long
    
    Set ws = ThisWorkbook.ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    
    ' 关闭系统提速设置
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    ' 清除现有筛选
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    ' 筛选H列值为0的行（从第2行表头下开始）
    ws.Range("H2:H" & lastRow).AutoFilter Field:=1, Criteria1:=0
    
    ' 批量删除筛选出的可见行（跳过表头）
    On Error Resume Next ' 避免无符合条件行时报错
    ws.Range("A3:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    On Error GoTo 0
    
    ' 关闭筛选
    ws.AutoFilterMode = False
    
    ' 恢复系统设置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
    MsgBox "H列值为0的行已删除", vbInformation
End Sub

方案2：数组重构法（速度最快，适合超大数据量） #

将所有数据读入内存数组，遍历筛选出符合条件的行后，一次性写回工作表，全程避免操作工作表行结构，效率拉满。

Sub KeepNonZeroHRows_Array()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim dataArr As Variant, resultArr As Variant
    Dim i As Long, j As Long, resultRow As Long
    
    Set ws = ThisWorkbook.ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    lastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column ' 假设第2行为表头
    
    ' 读取全量数据到内存数组
    dataArr = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol)).Value
    ReDim resultArr(1 To UBound(dataArr, 1), 1 To UBound(dataArr, 2))
    resultRow = 0
    
    ' 关闭系统提速设置
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    ' 遍历数组，保留H列（第8列）非0的行
    For i = 1 To UBound(dataArr, 1)
        If Not (dataArr(i, 8) = 0 Or IsEmpty(dataArr(i, 8))) Then
            resultRow = resultRow + 1
            ' 复制整行数据到结果数组
            For j = 1 To UBound(dataArr, 2)
                resultArr(resultRow, j) = dataArr(i, j)
            Next j
        End If
    Next i
    
    ' 清空原数据区域并写入筛选后的数据
    ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol)).ClearContents
    If resultRow > 0 Then
        ws.Range(ws.Cells(2, 1), ws.Cells(resultRow + 1, lastCol)).Value = resultArr
    End If
    
    ' 恢复系统设置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
    MsgBox "已保留H列非0的行，共保留 " & resultRow & " 行", vbInformation
End Sub

注意事项 #

• 运行前建议备份文件，避免误操作
• 若H列是公式，两种方案均能正确识别计算结果
• 数组法中如果表头不是第2行，需修改代码中对应的行号参数

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