如何在VBA数组中搜索指定列并统计指定范围的重复项？

原代码用WorksheetFunction.CountIf慢的核心原因是频繁读写工作表，每次调用都会触发Excel的单元格交互，十万次下来必然卡顿。改用内存数组+字典的组合，能把速度提升几个数量级，以下是两种可行方案：

方案1：字典（推荐，O(n)时间复杂度） #

利用字典的键唯一性特性，直接记录每个零件号的出现次数，无需遍历前置数组，效率最高：

Sub MarkDuplicates_WithDictionary()
    Dim ws As Worksheet
    Dim dataArr As Variant, resultArr As Variant
    Dim partDict As Object
    Dim i As Long, lastRow As Long
    Dim partNum As String
    
    ' 初始化对象
    Set ws = ThisWorkbook.Sheets("你的工作表名") ' 替换成实际表名
    Set partDict = CreateObject("Scripting.Dictionary")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 假设零件号在A列
    
    ' 关闭Excel耗时操作
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 读取数据到数组（内存操作）
    dataArr = ws.Range("A2:B" & lastRow).Value ' 假设A是零件号，B是标记列
    ReDim resultArr(1 To UBound(dataArr, 1), 1 To 1) ' 存储标记结果
    
    ' 遍历数组
    For i = 1 To UBound(dataArr, 1)
        partNum = Trim(dataArr(i, 1)) ' 去除空格避免误判
        If partDict.Exists(partNum) Then
            ' 已存在，标记重复
            resultArr(i, 1) = "D"
            partDict(partNum) = partDict(partNum) + 1
        Else
            ' 首次出现，标记唯一
            resultArr(i, 1) = "U"
            partDict.Add partNum, 1
        End If
    Next i
    
    ' 将结果写回工作表
    ws.Range("B2:B" & lastRow).Value = resultArr
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    ' 释放对象
    Set partDict = Nothing
    Set ws = Nothing
End Sub

方案2：纯数组遍历（符合你要求的“从顶部搜索到当前行”） #

如果必须遍历当前行之前的数组元素，这种方法时间复杂度是O(n²)，十万行下会比字典慢很多，但能满足你的需求：

Sub MarkDuplicates_WithArrayOnly()
    Dim ws As Worksheet
    Dim dataArr As Variant, resultArr As Variant
    Dim i As Long, j As Long, lastRow As Long
    Dim partNum As String, count As Long
    
    Set ws = ThisWorkbook.Sheets("你的工作表名")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 关闭耗时操作
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    dataArr = ws.Range("A2:B" & lastRow).Value
    ReDim resultArr(1 To UBound(dataArr, 1), 1 To 1)
    
    For i = 1 To UBound(dataArr, 1)
        partNum = Trim(dataArr(i, 1))
        count = 0
        ' 从数组顶部（第1行）遍历到当前行的前一行
        For j = 1 To i - 1
            If Trim(dataArr(j, 1)) = partNum Then
                count = count + 1
                Exit For ' 找到一个重复就可以停止，不用继续遍历
            End If
        Next j
        
        resultArr(i, 1) = IIf(count = 0, "U", "D")
    Next i
    
    ws.Range("B2:B" & lastRow).Value = resultArr
    
    ' 恢复设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    Set ws = Nothing
End Sub

关键优化说明 #

• 所有数据先读入数组，仅在最后一次性写回工作表，避免频繁IO
• 关闭ScreenUpdating、Calculation、EnableEvents能大幅减少Excel后台开销
• 字典方案中，Trim()处理零件号是为了避免因空格导致的误判，可根据实际情况调整

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