Excel VBA去重宏异常：误删手动录入数据行求助

问题背景 #

需处理Excel表格，规则为：删除I列重复值中CF列创建日期最新的无手动录入数据的行。现有宏通过Scripting.Dictionary存储I列值，对比CF列日期标记待删除行，但偶尔会误删含手动数据的旧行，无法稳定复现。

现有代码 #

Sub supprimerDoublons()
    Dim derniereligne As Long
    Dim dict As Object
    Dim a As Long
    Dim x As Variant
    Dim rngToDelete As Range
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    derniereligne = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
    
    For a = 5 To derniereligne
        x = Cells(a, "I").Value
        If Not dict.exists(x) Then
            dict.Add x, a
        Else
            If Cells(a, "CF").Value > Cells(dict(x), "CF").Value Then
                If rngToDelete Is Nothing Then
                    Set rngToDelete = Rows(a)
                Else
                    Set rngToDelete = Union(rngToDelete, Rows(a))
                End If
            Else
                If rngToDelete Is Nothing Then
                    Set rngToDelete = Rows(dict(x))
                Else
                    Set rngToDelete = Union(rngToDelete, Rows(dict(x)))
                End If
                dict.Item(x) = a
            End If
        End If
    Next a
    
    If Not rngToDelete Is Nothing Then
        rngToDelete.Delete
    End If
    
End Sub

问题分析 #

1. 核心逻辑缺失：代码未区分手动录入行与自动生成行，仅通过CF列日期比较决定删除对象。当手动旧行日期早于自动新行时，手动行被误删。
2. 遍历隐患：从第5行到最后一行遍历，若后续出现手动行，字典中存储的行号会被自动行覆盖，导致后续判断出错。

修复方案 #

先明确手动录入行的判断标识（示例假设CI列标记"手动"，可根据实际表格调整），修改逻辑优先级：

• 优先保留手动录入行，无论日期新旧
• 仅当两行都是自动行时，保留CF列日期旧的，删除日期新的

修改后的代码 #

Sub supprimerDoublons_Ameliorer()
    Dim derniereligne As Long
    Dim dict As Object
    Dim a As Long
    Dim x As Variant
    Dim rngToDelete As Range
    Dim isCurrentManual As Boolean
    Dim isStoredManual As Boolean
    
    Set dict = CreateObject("Scripting.Dictionary")
    derniereligne = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
    
    For a = 5 To derniereligne
        x = Cells(a, "I").Value
        ' 判断当前行是否为手动录入行（可自行修改列或判断规则）
        isCurrentManual = (Cells(a, "CI").Value = "手动")
        
        If Not dict.exists(x) Then
            dict.Add x, a
        Else
            isStoredManual = (Cells(dict(x), "CI").Value = "手动")
            
            Select Case True
                ' 存储行是手动，当前行是自动 → 删除当前行
                Case isStoredManual And Not isCurrentManual
                    AddToDeleteRange rngToDelete, Rows(a)
                
                ' 存储行是自动，当前行是手动 → 删除旧自动行，更新字典为手动行
                Case Not isStoredManual And isCurrentManual
                    AddToDeleteRange rngToDelete, Rows(dict(x))
                    dict.Item(x) = a
                
                ' 两行都是自动 → 保留旧日期行，删除新日期行
                Case Not isStoredManual And Not isCurrentManual
                    If Cells(a, "CF").Value > Cells(dict(x), "CF").Value Then
                        AddToDeleteRange rngToDelete, Rows(a)
                    Else
                        AddToDeleteRange rngToDelete, Rows(dict(x))
                        dict.Item(x) = a
                    End If
                
                ' 两行都是手动 → 保留先出现的，删除当前行（可按需调整）
                Case Else
                    AddToDeleteRange rngToDelete, Rows(a)
            End Select
        End If
    Next a
    
    If Not rngToDelete Is Nothing Then
        rngToDelete.Delete
    End If
    
End Sub

' 辅助过程：简化待删除区域的合并操作
Sub AddToDeleteRange(ByRef targetRange As Range, ByVal addRow As Range)
    If targetRange Is Nothing Then
        Set targetRange = addRow
    Else
        Set targetRange = Union(targetRange, addRow)
    End If
End Sub

关键改动说明 #

1. 新增手动行判断：通过指定列标记区分手动/自动行，可根据实际表格调整判断规则。
2. 分层逻辑判断：按手动/自动行的组合场景分优先级处理，确保手动行不会被误删。
3. 提取辅助过程：将重复的区域合并逻辑封装为独立过程，简化主代码，减少出错概率。
4. 明确边界处理：针对两行都是手动行的场景给出默认处理规则，可按需调整。

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