Excel VBA如何删除3列重复且其中一列为空白的行，保留完整数据行？

需求说明 #

现有3列数据，删除重复行规则如下：

• 以第1、3列内容作为重复判定基准，两列内容均一致即判定为同组重复行
• 同组重复行中优先保留第2列有内容的行，删除第2列为空的行
• 若同组内有多行第2列均有内容，仅保留1行即可

原有代码问题 #

原有代码直接调用RemoveDuplicates无法实现优先保留第2列非空行的需求，该方法默认保留首次出现的行，不会自动判断列内容完整性。

修正后可运行代码 #

Sub DeleteDuplicateRows()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dict As Object
    Dim i As Long
    Dim key As String
    Dim deleteRange As Range
    
    Set ws = ThisWorkbook.ActiveSheet
    ' 假设你的3列数据从F列开始，即F、G、H对应规则中的第1、2、3列
    lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 第一轮遍历：标记需要保留的行，优先保留第2列非空的行
    For i = 1 To lastRow
        ' 拼接1、3列内容作为分组唯一键
        key = ws.Cells(i, "F").Value & "|" & ws.Cells(i, "H").Value
        If Not dict.exists(key) Then
            dict(key) = i
        Else
            ' 同组内如果当前行第2列非空，已记录的行第2列为空，更新保留行
            If ws.Cells(i, "G").Value <> "" And ws.Cells(dict(key), "G").Value = "" Then
                dict(key) = i
            End If
        End If
    Next i
    
    ' 第二轮遍历：收集所有需要删除的行
    For i = 1 To lastRow
        key = ws.Cells(i, "F").Value & "|" & ws.Cells(i, "H").Value
        If dict(key) <> i Then
            If deleteRange Is Nothing Then
                Set deleteRange = ws.Rows(i)
            Else
                Set deleteRange = Union(deleteRange, ws.Rows(i))
            End If
        End If
    Next i
    
    ' 批量删除标记行
    If Not deleteRange Is Nothing Then
        deleteRange.Delete
    End If
    
    ' 释放对象内存
    Set dict = Nothing
    Set ws = Nothing
    Set deleteRange = Nothing
End Sub

自定义调整提示 #

如果你的3列数据不是从F列起始，修改代码中对应的列标识即可：

• 规则中的第1列对应拼接key的第一个字段
• 规则中的第2列对应非空判断的字段
• 规则中的第3列对应拼接key的第二个字段

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