VBA比较两个列表并删除不同列中具有重复值的行

Posted 2023-03-29

【中文标题】VBA比较两个列表并删除不同列中具有重复值的行

【英文标题】：VBA compare two lists and remove row with duplicate value in different column

【发布时间】：2021-08-09 02:12:33

【问题描述】：

我有两个包含几列的列表。有些列不同，但许多列相同且顺序不同。

如何比较 List1 和 List2，以及（例如）删除 List1 的第 34 行，因为 List1 的单元格 E34 = List2 的 H10

由于预先确定的格式：List1 从第 12 行开始（第 11 行的标题），而 List2 从第 7 行开始（第 6 行的标题）

Sub ClearDuplicate()

Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim C1row As Long
Dim C2row As Long
Dim C2TotalRows As Long
Dim SerialNumber As String
Dim NoDups As Long

Set sht1 = Worksheets("Open Report")
Set sht2 = Worksheets("FNDWRR")
sht2.Activate
C2TotalRows = Application.CountA(Range("H:H"))
C1row = 12

Do While sht1.Cells(C1row, 5).Value <> ""

SerialNumber = sht1.Cells(C1row, 5).Value

    For C2row = 7 To C2TotalRows

        If SerialNumber = Cells(C2row, 8).Value Then
            
            sht1.Activate
            Rows(C1row).Delete
            NoDups = NoDups + 1
            C1row = C1row - 1
            sht2.Activate
            Exit For
        
        End If
        
    Next
    
    C1row = C1row + 1

Loop
    
MsgBox NoDups & " Duplicates were removed"

End Sub

【问题讨论】：

我可能会为每一列构建一个Dictionary，并将每个单元格中的.Value 添加为“键”，将行号添加为“值”。然后使用每个字典中的.Keys 进行比较，并根据您的发现，您可以使用存储的行号来删除/编辑/修改工作表。有关一些信息，请参阅this site。

【参考方案1】：

删除重复行 (Application.Match)

以下内容将删除目标工作表中的所有行，其中给定列中的值也在源工作表的给定列中找到。 代码 (deleteDupeRows) 使用两个函数“简化”：refNonEmptyColumn 和 getCombinedRange。

Option Explicit

Sub deleteDupeRows()

    ' Source
    Const sName As String = "FNDWRR"
    Const sFirst As String = "H7"
    ' Destination
    Const dName As String = "Open Report"
    Const dFirst As String = "E12"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    'Debug.Print wb.Name
    
    ' Create a reference to the Source Range.
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = refNonEmptyColumn(sws.Range(sFirst))
    If srg Is Nothing Then Exit Sub
    'Debug.Print sws.Name, srg.Address
    
    ' Create a reference to the Destination Range.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim drg As Range: Set drg = refNonEmptyColumn(dws.Range(dFirst))
    If drg Is Nothing Then Exit Sub
    'Debug.Print dws.Name, drg.Address
    
    ' Combine matching destination cells into a range.
    Dim crg As Range
    Dim dCell As Range
    Dim dCount As Long
    For Each dCell In drg.Cells
        If IsNumeric(Application.Match(dCell.Value, srg, 0)) Then
            Set crg = getCombinedRange(crg, dCell)
            dCount = dCount + 1
        End If
    Next dCell
    
    ' Delete entire rows of matching destination cells in one go.
    If crg Is Nothing Then
        MsgBox "No duplicates found.", vbExclamation, "Dupes"
    Else
        'crg.Worksheet.Activate
        'crg.EntireRow.Select
        'Debug.Print crg.Worksheet.Name, crg.Address
        'Debug.Print crg.Worksheet.Name, crg.EntireRow.Address
        crg.EntireRow.Delete
        If dCount = 1 Then
            MsgBox "1 duplicate removed.", vbInformation, "Dupes"
        Else
            MsgBox dCount & " duplicates removed.", vbInformation, "Dupes"
        End If
    End If

End Sub

Function refNonEmptyColumn( _
    FirstCell As Range) _
As Range
    Const ProcName As String = "refNonEmptyColumn"
    On Error GoTo clearError
    
    If Not FirstCell Is Nothing Then
        With FirstCell.Cells(1)
            Dim lCell As Range
            Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
                .Find("*", , xlFormulas, , , xlPrevious)
            If Not lCell Is Nothing Then
                Set refNonEmptyColumn = .Resize(lCell.Row - .Row + 1)
            End If
        End With
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Function getCombinedRange( _
        ByVal BuiltRange As Range, _
        ByVal AddRange As Range) _
As Range
    Const ProcName As String = "getCombinedRange"
    On Error GoTo clearError
    
    If AddRange Is Nothing Then
        If Not BuiltRange Is Nothing Then
            Set getCombinedRange = BuiltRange
        End If
    Else
        If BuiltRange Is Nothing Then
            Set getCombinedRange = AddRange
        Else
            If AddRange.Worksheet Is BuiltRange.Worksheet Then
                Set getCombinedRange = Union(BuiltRange, AddRange)
            End If
        End If
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

【讨论】：

我尝试运行您的代码，但出现“下标超出范围（错误 9）”错误 `` ' 创建对源范围的引用。将 sws 调暗为工作表：设置 sws = wb.Worksheets(sName)