如何优化Excel VBA批量移除重复产品序列号的执行效率？

原方法的核心问题是反复遍历工作表+全列CountIf查询，这在大数据量下效率极低。以下是针对性的优化思路和代码：

核心优化点 #

• 使用Dictionary存储停用序列号：字典的键查找是常数时间，替代效率低下的CountIf全列扫描
• 用数组读写数据：避免反复操作工作表（工作表IO是VBA中最慢的操作之一）
• 批量标记/写入：避免逐行删除的性能损耗
• 减少工作表激活/切换：直接通过对象操作，无需激活工作簿/工作表

优化后的VBA代码 #

Sub RemoveDisabledSNs()
    ' 关闭Excel界面相关设置提升运行速度
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim mainWB As Workbook, disabledWB As Workbook
    Dim mainWS As Worksheet, disabledWS As Worksheet
    Dim disabledDict As Object
    Dim mainData As Variant, keepRows As Variant
    Dim lastRowMain As Long, lastRowDisabled As Long
    Dim i As Long, keepCount As Long
    Dim fileNameAndPath As Variant
    
    ' 初始化主工作簿和工作表（可改为指定表名，如mainWB.Sheets("主序列号列表")）
    Set mainWB = ActiveWorkbook
    Set mainWS = mainWB.ActiveSheet
    
    ' 选择停用序列号工作簿
    fileNameAndPath = Application.GetOpenFilename(title:="选择停用序列号文件")
    If fileNameAndPath = False Then GoTo Cleanup
    
    ' 只读打开停用工作簿，读取数据到字典
    Set disabledWB = Workbooks.Open(Filename:=fileNameAndPath, ReadOnly:=True)
    Set disabledWS = disabledWB.ActiveSheet
    lastRowDisabled = disabledWS.Range("A" & disabledWS.Rows.Count).End(xlUp).Row
    
    Set disabledDict = CreateObject("Scripting.Dictionary")
    ' 跳过表头，将停用序列号存入字典（去重）
    For i = 2 To lastRowDisabled
        Dim snValue As Variant
        snValue = disabledWS.Cells(i, "A").Value
        If Not disabledDict.Exists(snValue) Then
            disabledDict.Add snValue, True
        End If
    Next i
    disabledWB.Close SaveChanges:=False ' 用完立即关闭，释放资源
    
    ' 读取主序列号数据到数组（假设主数据从B2开始）
    lastRowMain = mainWS.Range("B" & mainWS.Rows.Count).End(xlUp).Row
    mainData = mainWS.Range("B2:B" & lastRowMain).Value
    
    ' 筛选并保留非停用序列号
    ReDim keepRows(1 To UBound(mainData), 1 To 1)
    keepCount = 0
    For i = 1 To UBound(mainData)
        If Not disabledDict.Exists(mainData(i, 1)) Then
            keepCount = keepCount + 1
            keepRows(keepCount, 1) = mainData(i, 1)
        End If
    Next i
    
    ' 清空原数据区域，写入保留内容
    mainWS.Range("B2:B" & lastRowMain).ClearContents
    If keepCount > 0 Then
        mainWS.Range("B2").Resize(keepCount, 1).Value = keepRows
    End If
    
Cleanup:
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    ' 释放对象资源
    Set disabledDict = Nothing
    Set mainWS = Nothing
    Set mainWB = Nothing
    Set disabledWS = Nothing
    Set disabledWB = Nothing
    
    MsgBox "处理完成，共保留 " & keepCount & " 条有效序列号"
End Sub

额外注意事项 #

• 确保序列号为文本格式：避免因数字/文本格式不一致导致匹配失败
• 若主表包含关联列：可修改代码读取整行数据，筛选后批量写入，避免仅保留序列号列
• 先做小批量测试：验证逻辑正确后再处理全量数据，避免误删

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