VBA拆分文件后删除行效率低下，求高效优化方案

一、耗时是否正常？ #

近1小时的执行时间完全不正常。核心耗时点集中在逐单元格循环标记删除行、对ListObject逐行逆序删除这两个操作上——这类逻辑会触发Excel频繁的重绘与计算，在数据量大时效率极低。

二、核心优化思路 #

行删除的低效根源是频繁直接操作工作表对象，最优优化方向是：

• 用内存数组替代逐单元格读取，减少与工作表的交互次数
• 批量标记所有目标行，一次性执行删除操作，避免多次零散操作
• 对ListObject直接用筛选功能批量删除，彻底抛弃逐行循环逻辑

三、具体代码优化调整 #

1. 全局环境优化（Bud_Split & ProcessWorkbook） #

一次性关闭所有影响速度的Excel自动功能，避免在子过程中反复开关增加开销：

Sub Bud_Split()
    startTime = Timer
    ' 全局关闭耗资源功能
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    ' 原文件选择、复制、删除逻辑保留不变
    
    ' 处理文件循环逻辑保留不变
    
    ' 恢复环境设置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    
    ' 原计时、弹窗逻辑保留不变
End Sub

Sub ProcessWorkbook(workbookPath As String)
    Dim wb As Workbook
    ' 打开文件时关闭链接更新，减少等待
    Set wb = Workbooks.Open(workbookPath, UpdateLinks:=0)
    
    ' 原B6单元格赋值逻辑保留不变
    
    ' 移除不必要的工作表激活代码（完全不影响功能，纯耗资源）
    ' wb.Sheets("Overall").Activate
    ' wb.Sheets("Overall").Range("A1").Activate
    
    wb.Close SaveChanges:=True
End Sub

2. 重写普通工作表行删除函数（替代DeleteRowsByCriteria） #

用内存数组批量判断，一次性删除目标行：

Sub DeleteRowsByCriteria_Fast(ws As Worksheet, columnIndex As Long, criteria As Variant)
    Dim lastRow As Long, i As Long
    Dim deleteRows As Range
    Dim dataArr As Variant
    
    lastRow = ws.Cells(ws.Rows.Count, columnIndex).End(xlUp).Row
    If lastRow < 1 Then Exit Sub
    
    ' 把整列数据读入内存数组，避免反复读取工作表
    dataArr = ws.Cells(1, columnIndex).Resize(lastRow, 1).Value
    
    ' 批量标记要删除的行
    For i = 1 To UBound(dataArr)
        If dataArr(i, 1) = criteria Then
            If deleteRows Is Nothing Then
                Set deleteRows = ws.Rows(i)
            Else
                Set deleteRows = Union(deleteRows, ws.Rows(i))
            End If
        End If
    Next i
    
    ' 一次性删除所有标记行
    If Not deleteRows Is Nothing Then deleteRows.Delete
End Sub

3. 重写ListObject行删除函数（替代DeleteTableRowsByCriteria） #

用筛选功能批量删除，效率提升10倍以上：

Sub DeleteTableRowsByCriteria_Fast(ws As Worksheet, tableName As String, columnIndex As Long, criteria As Variant)
    Dim tbl As ListObject
    Set tbl = ws.ListObjects(tableName)
    If tbl Is Nothing Then Exit Sub
    
    ' 清除原有筛选状态
    If tbl.AutoFilter.FilterMode Then tbl.AutoFilter.ShowAllData
    
    ' 对目标列应用筛选，匹配要删除的内容
    tbl.ListColumns(columnIndex).Range.AutoFilter Field:=1, Criteria1:=criteria
    
    ' 删除筛选后的可见行（跳过表头）
    On Error Resume Next ' 处理无匹配行的异常
    tbl.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
    On Error GoTo 0
    
    ' 清除筛选
    tbl.AutoFilter.ShowAllData
End Sub

4. 替换原调用逻辑 #

在ProcessWorkbook中把旧的删除函数调用替换为新函数：

' 替换原循环调用
For Each sheetName In sheetNames
    DeleteRowsByCriteria_Fast wb.Sheets(sheetName), 1, "Delete"
Next sheetName

DeleteTableRowsByCriteria_Fast wb.Sheets("Lookup"), "Lookup", 3, "Delete"

四、额外提速技巧 #

• 改用.xlsb格式：二进制格式的读写速度远快于.xlsx，原文件和拆分后的子文件都建议用此格式
• 优化文件拆分逻辑：直接打开原文件，另存为新文件名后再处理，减少一次FileCopy的IO开销
• 关闭不必要的加载项：暂时禁用非必需的Excel加载项，减少后台资源占用

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