Excel VBA宏本该跳过重复值却写入重复值，该如何排查？

我需要将多个Excel工作表的数据合并到主表，仅同步新增数据。当前代码能正常添加新值，但运行数分钟后会开始写入重复值。代码逻辑是从Sheet2提取单元格值，用Find函数检查Sheet1是否存在该NDC，不存在则添加至Sheet1。我知道代码可优化（比如将Sheet2内容存入数组），以下是现有代码及示例表：

示例表（注：实际各工作表行数约250k-300k） #

现有VBA代码 #

Sub DoTheThing()

    'This sub is ran from Sheet 2
    Application.ScreenUpdating = False

    Dim rowZ As Long, NDC As String, Avg As String, drugName As String, newCounter As Long

    rowZ = Range("A1").CurrentRegion.Rows.Count
    newCounter = 0

    For i = 2 To rowZ 'Start at 2 to ignore table headers
        NDC = Cells(i, 1)
        Avg = Cells(i, 2)
        drugName = Cells(i, 3)
        If Does_NDC_Exist(NDC, Avg, drugName) Then
            'Debug.Print "NDC does exist"
        Else
            'Debug.Print Cells(i, 3) & NDC & " does not exist"
            newCounter = newCounter + 1
        End If

    Next i

    Debug.Print "Added " & newCounter & " to Compiled list"

    Application.ScreenUpdating = True

End Sub

Function Does_NDC_Exist(NDC As String, Avg As String, drugName As String) As Boolean

    Dim rngAddress As Range
    Set rngAddress = Worksheets(1).Range("A:A").Find(NDC, LookIn:=xlValues, LookAt:=xlWhole)
    
    If rngAddress Is Nothing Then
        Does_NDC_Exist = False
        'Call ddFunctions.StoreData(NDC)
        Call AddNewNDC(NDC, Avg, drugName)
    Else
        Does_NDC_Exist = True
    End If

End Function

Function AddNewNDC(NDC As String, Avg As String, drugName As String)

    Dim rowZ As Long
    rowZ = Worksheets(1).Range("A1").CurrentRegion.Rows.Count
    Cells(rowZ + 1, 1).Select
    Worksheets(1).Cells(rowZ + 1, 1).Value = NDC
    Worksheets(1).Cells(rowZ + 1, 2).Value = Avg
    Worksheets(1).Cells(rowZ + 1, 3).Value = drugName

End Function

我研究这个问题好几周了（刚接触VBA，正在学习），手动单步执行代码时不会出现重复值，怀疑是跨表操作过快导致的，现在不知道该怎么解决。

问题原因分析 #

1. Find函数参数残留：Find函数会保留上一次的搜索参数（如起始位置、搜索方向），未显式指定参数时，多次调用可能出现搜索遗漏，误判NDC不存在从而重复写入。
2. 动态行计数滞后：每次新增数据后，主表的CurrentRegion会变化，但循环中未同步最新状态，大数量级数据下的操作延迟会加剧这个问题。
3. 逐行操作性能瓶颈：250k+行数据下，逐单元格读取+逐行调用Find的方式效率极低，长时间运行可能引发Excel缓存同步问题，导致判断逻辑出错。

解决方案 #

方案1：修复现有逻辑漏洞 #

针对Find和行计数问题，改用字典存储已存在的NDC，避免重复判断：

Sub DoTheThing_Fixed()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual '禁用自动计算提升性能
    
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Set wsSource = ThisWorkbook.Worksheets("Sheet2")
    Set wsTarget = ThisWorkbook.Worksheets(1)
    
    Dim rowZ As Long, newCounter As Long, targetLastRow As Long
    Dim NDC As String, Avg As String, drugName As String
    
    rowZ = wsSource.Range("A1").CurrentRegion.Rows.Count
    newCounter = 0
    
    '用字典存储主表已有的NDC，O(1)查询效率
    Dim ndcDict As Object
    Set ndcDict = CreateObject("Scripting.Dictionary")
    targetLastRow = wsTarget.Range("A1").CurrentRegion.Rows.Count
    
    Dim i As Long
    For i = 2 To targetLastRow
        NDC = wsTarget.Cells(i, 1).Value
        If Not ndcDict.Exists(NDC) Then
            ndcDict.Add NDC, True
        End If
    Next i
    
    '遍历源表筛选新增数据
    For i = 2 To rowZ
        NDC = wsSource.Cells(i, 1).Value
        Avg = wsSource.Cells(i, 2).Value
        drugName = wsSource.Cells(i, 3).Value
        
        If Not ndcDict.Exists(NDC) Then
            targetLastRow = targetLastRow + 1
            wsTarget.Cells(targetLastRow, 1).Value = NDC
            wsTarget.Cells(targetLastRow, 2).Value = Avg
            wsTarget.Cells(targetLastRow, 3).Value = drugName
            ndcDict.Add NDC, True '更新字典避免后续重复添加
            newCounter = newCounter + 1
        End If
    Next i
    
    Debug.Print "Added " & newCounter & " to Compiled list"
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

方案2：大数量级优化（数组读取+批量写入） #

针对250k+行数据，用数组一次性读取所有数据，彻底解决性能和同步问题：

Sub DoTheThing_Optimized()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Set wsSource = ThisWorkbook.Worksheets("Sheet2")
    Set wsTarget = ThisWorkbook.Worksheets(1)
    
    Dim sourceData As Variant, targetData As Variant
    Dim ndcDict As Object
    Set ndcDict = CreateObject("Scripting.Dictionary")
    
    '读取主表数据到数组，并存入字典
    targetData = wsTarget.Range("A1").CurrentRegion.Value
    Dim i As Long, ndcKey As String
    For i = 2 To UBound(targetData, 1)
        ndcKey = CStr(targetData(i, 1))
        If Not ndcDict.Exists(ndcKey) Then
            ndcDict.Add ndcKey, True
        End If
    Next i
    
    '读取源表数据到数组
    sourceData = wsSource.Range("A1").CurrentRegion.Value
    Dim newRows As Collection
    Set newRows = New Collection
    
    '筛选源表新增数据
    For i = 2 To UBound(sourceData, 1)
        ndcKey = CStr(sourceData(i, 1))
        If Not ndcDict.Exists(ndcKey) Then
            newRows.Add Array(sourceData(i, 1), sourceData(i, 2), sourceData(i, 3))
            ndcDict.Add ndcKey, True
        End If
    Next i
    
    '批量写入新增数据到主表
    Dim targetLastRow As Long
    targetLastRow = UBound(targetData, 1)
    If newRows.Count > 0 Then
        wsTarget.Cells(targetLastRow + 1, 1).Resize(newRows.Count, 3).Value = _
            Application.Transpose(Application.Transpose(newRows))
    End If
    
    Debug.Print "Added " & newRows.Count & " to Compiled list"
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

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