如何一次性检测重复项？寻求替代逐次检测的VBA优化方案

当然可以用字典（Dictionary）或者数组批量匹配的方式替代逐次遍历Find的低效逻辑，尤其在数据量较大时，能大幅提升运行效率。下面给出两种实用方案：

方法一：利用字典快速查重 #

字典通过键值对实现O(1)级别的查找效率，先把E列已有的数据全部存入字典，再一次性遍历ListBox项检查是否存在，仅需两次遍历即可完成检测。

Private Sub checkDuplicates(wks As Worksheet)
    Dim lastRow As Long
    ' 修正原代码的跨表引用问题，明确指定工作表
    lastRow = wks.Cells(wks.Rows.Count, "E").End(xlUp).Row
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim listArr As Variant
    Dim n As Long
    Dim duplicateItems As String
    
    ' 1. 将E列已存在数据加载到字典（从E4开始）
    If lastRow >= 4 Then
        Dim eArr As Variant
        eArr = wks.Range("E4:E" & lastRow).Value
        For n = 1 To UBound(eArr)
            ' 跳过空值，避免无效匹配
            If Not IsEmpty(eArr(n, 1)) Then
                dict(eArr(n, 1)) = True
            End If
        Next n
    End If
    
    ' 2. 批量检查ListBox项
    listArr = Me.ListboxResult.List
    For n = 0 To UBound(listArr)
        Dim currentItem As Variant
        currentItem = listArr(n, 1)
        If dict.Exists(currentItem) Then
            ' 收集所有重复项，统一弹窗提示
            duplicateItems = duplicateItems & vbCrLf & "- " & currentItem
        Else
            Call addToNewRow(wks, lastRow + 1, n)
            ' 将新增项加入字典，避免ListBox内部重复项被误加
            dict(currentItem) = True
            lastRow = lastRow + 1
        End If
    Next n
    
    ' 统一提示重复结果
    If duplicateItems <> "" Then
        MsgBox "发现以下重复项：" & vbCrLf & duplicateItems, vbOKOnly, "重复项检测"
    End If
End Sub

方法优势 #

• 仅需两次遍历操作，比原代码的N次Find调用效率提升明显
• 统一收集重复项后一次性弹窗，避免频繁弹窗打断操作
• 修正了原代码未指定工作表的Cells引用问题，避免跨表错误

方法二：利用数组+Application.Match批量匹配 #

借助Excel内置的Application.Match函数，可一次性对数组进行匹配，快速定位重复项位置。

Private Sub checkDuplicates(wks As Worksheet)
    Dim lastRow As Long
    lastRow = wks.Cells(wks.Rows.Count, "E").End(xlUp).Row
    Dim eArr As Variant
    Dim listArr As Variant
    Dim matchResult As Variant
    Dim n As Long
    Dim duplicateItems As String
    
    ' 准备E列数据数组
    If lastRow >= 4 Then
        eArr = wks.Range("E4:E" & lastRow).Value
    Else
        eArr = Array() ' E4以下无数据时初始化空数组
    End If
    
    ' 提取ListBox第2列（索引1）的数据到单独数组
    listArr = Me.ListboxResult.List
    Dim listColArr As Variant
    ReDim listColArr(0 To UBound(listArr))
    For n = 0 To UBound(listArr)
        listColArr(n) = listArr(n, 1)
    Next n
    
    ' 批量匹配，返回每个ListBox项在E列的位置，无匹配则返回错误值
    matchResult = Application.Match(listColArr, eArr, 0)
    
    ' 遍历匹配结果
    For n = 0 To UBound(matchResult)
        If Not IsError(matchResult(n + 1)) Then ' Match返回的数组为1基索引
            duplicateItems = duplicateItems & vbCrLf & "- " & listArr(n, 1)
        Else
            Call addToNewRow(wks, lastRow + 1, n)
            lastRow = lastRow + 1
        End If
    Next n
    
    ' 统一提示重复结果
    If duplicateItems <> "" Then
        MsgBox "发现以下重复项：" & vbCrLf & duplicateItems, vbOKOnly, "重复项检测"
    End If
End Sub

方法优势 #

• 利用Excel内置函数的优化，代码更简洁
• 无需引用字典对象，避免额外的引用设置操作
• 适合数据量中等的场景

额外优化提示 #

原代码中lastRow的计算使用了Offset(1,0).Row，存在逻辑瑕疵——加载E列数据时应该用原有数据的最后一行，而非新行的行号，上述两种方案已修正该问题。

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