VBA如何比对现有列表查重并仅添加新列表中的唯一实例

错误原因排查 #

• 触发运行时错误1004的核心原因有两个：
  1. New List工作表A列存在单元格错误值（如#N/A、#DIV/0!等），错误值无法作为字典的Key存入
  2. New List工作表A列本身存在重复值，Dict.Add方法遇到重复Key会直接抛出异常，需先判断Key是否存在再添加
• 除此之外原代码逻辑未完成：仅做了字典存储和存在性判断，没有实现「提取New List唯一值、追加到Active List末尾」的需求，且字典存储逻辑倒置，应该先存Active List已有值用于去重。

修复后完整代码 #

无需手动引用Scripting Runtime库，直接复制即可运行：

Sub load_new()
    Dim LastRow As Long
    Dim i As Long
    Dim Dict As Object
    ' 后期绑定，避免引用配置问题
    Set Dict = CreateObject("Scripting.Dictionary")
    ' 不需要区分大小写查重可以删除下一行
    Dict.comparemode = vbTextCompare
    
    Dim NL As Worksheet, AL As Worksheet
    Set NL = ThisWorkbook.Worksheets("NEW LIST")
    Set AL = ThisWorkbook.Worksheets("ACTIVE LIST")
    
    ' 第一步：存入Active List B列已有值用于去重
    With AL
        LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        For i = 2 To LastRow
            ' 跳过错误值避免报错
            If Not IsError(.Cells(i, 2).Value) Then
                If Not Dict.exists(.Cells(i, 2).Value) Then
                    Dict.Add Key:=.Cells(i, 2).Value, Item:=vbNullString
                End If
            End If
        Next i
    End With
    
    ' 第二步：遍历New List提取唯一值，存入数组提升写入效率
    Dim tempArr As Variant, arrCount As Long
    ' 预设数组容量，可根据实际数据量调整
    ReDim tempArr(1 To 10000, 1 To 2)
    arrCount = 0
    With NL
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To LastRow
            ' 跳过空值、错误值
            If Not IsEmpty(.Cells(i, 1).Value) And Not IsError(.Cells(i, 1).Value) Then
                If Not Dict.exists(.Cells(i, 1).Value) Then
                    arrCount = arrCount + 1
                    ' New List A列存入对应Active List B列
                    tempArr(arrCount, 1) = .Cells(i, 1).Value
                    ' New List B列存入对应Active List C列
                    tempArr(arrCount, 2) = .Cells(i, 2).Value
                    ' 写入字典避免New List内部重复
                    Dict.Add Key:=.Cells(i, 1).Value, Item:=vbNullString
                End If
            End If
        Next i
    End With
    
    ' 第三步：批量写入到Active List已有数据末尾
    If arrCount > 0 Then
        Dim ALNextRow As Long
        ALNextRow = AL.Cells(AL.Rows.Count, 2).End(xlUp).Row + 1
        AL.Cells(ALNextRow, 2).Resize(arrCount, 2).Value = tempArr
    End If
    
    ' 释放对象
    Set Dict = Nothing
    Set NL = Nothing
    Set AL = Nothing
End Sub

代码说明 #

• 兼容错误值、空值、重复值场景，彻底解决1004报错问题
• 采用数组批量写入，相比逐行写入效率提升10倍以上，适配大数据量场景
• 自动过滤New List内部重复值、以及和Active List重叠的重复值，完全匹配需求规则

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