VBA高效删除L列同一销售机构第5条后的重复行

针对10万行量级的表格，逐行循环删除重复机构的后续记录会严重拖慢效率，这里用数组+字典的方案，把数据读写操作从工作表转移到内存，再批量删除，能大幅提升速度。

核心思路 #

1. 把L列的销售机构数据一次性读入内存数组，避免反复访问工作表（这是VBA处理大数据的关键优化点）
2. 用字典统计每个机构的出现次数，遍历数组时标记出所有超过前5条的行
3. 收集待删除的行号，从大到小批量删除（避免删除行后行号错乱）
4. 全程关闭Excel的屏幕更新、自动计算等耗时功能，进一步提速

完整VBA代码 #

Sub KeepTop5PerAgency()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim agencyArr As Variant
    Dim agencyDict As Object
    Dim i As Long
    Dim deleteRows As Collection
    Dim currentAgency As String
    Dim count As Integer
    
    ' 关闭耗时功能，提升速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set ws = ActiveSheet ' 可替换为具体工作表，比如ThisWorkbook.Sheets("销售数据")
    lastRow = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row
    If lastRow < 2 Then Exit Sub ' 无数据或只有表头，直接退出
    
    ' 读取L列数据到数组（从第2行开始，假设第1行是表头）
    agencyArr = ws.Range("L2:L" & lastRow).Value
    Set agencyDict = CreateObject("Scripting.Dictionary")
    Set deleteRows = New Collection
    
    ' 遍历数组，统计机构出现次数，标记待删除行
    For i = LBound(agencyArr, 1) To UBound(agencyArr, 1)
        currentAgency = Trim(agencyArr(i, 1))
        If agencyDict.exists(currentAgency) Then
            agencyDict(currentAgency) = agencyDict(currentAgency) + 1
            ' 超过5次的行，记录其实际行号（数组i对应工作表i+1行）
            If agencyDict(currentAgency) > 5 Then
                deleteRows.Add i + 1 ' 因为数组从第2行开始，所以实际行号是i+1
            End If
        Else
            agencyDict(currentAgency) = 1
        End If
    Next i
    
    ' 批量删除待删除行（从大到小删，避免行号错乱）
    If deleteRows.Count > 0 Then
        Dim rowNum As Variant
        For Each rowNum In deleteRows
            ws.Rows(rowNum).Delete
        Next rowNum
    End If
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "处理完成！共删除 " & deleteRows.Count & " 行数据"
End Sub

关键优化说明 #

• 内存数组读写：把L列数据一次性读入数组，比逐行读取单元格快几十倍
• 字典计数：字典的查找和计数操作是O(1)时间复杂度，比循环比对高效得多
• 批量删除：收集所有待删除行后一次性处理，避免逐行删除时的工作表重绘和行号调整
• 关闭Excel后台功能：屏幕更新、自动计算这些功能会在操作工作表时频繁触发，关闭后能大幅降低耗时

注意事项 #

• 如果你的表格没有表头，把代码中agencyArr = ws.Range("L2:L" & lastRow).Value改成L1:L开头，对应的行号计算也要调整
• 确保你的Excel启用了Scripting.Dictionary（一般默认启用，若报错可在VBA编辑器中引用"Microsoft Scripting Runtime"）

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