如果整行使用 VBA 匹配，则删除重复的行

Posted 2023-03-29

【中文标题】如果整行使用 VBA 匹配，则删除重复的行

【英文标题】：Delete duplicated rows if the whole row matches using VBA

【发布时间】：2021-08-13 03:20:24

【问题描述】：

我正在尝试创建一个子程序，仅当整个行值重复时才删除重复的行（我的工作表有 20 列）。函数RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes 将删除错误的行，因为我可能在所有单元格中都有重复的值，但绝不是整行。我尝试使用RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), Header:=xlYes，但它给了我一个错误。所以我决定制作以下代码。代码的问题是我正在遍历所有单元格以验证任何重复的行。有没有更简单的方法来做到这一点？

谢谢！

Public Sub DeleteDupRows()

    Dim plLine As Integer: plLine = 2                   'sheet have header
    Dim plColumn As Integer: plColumn = 1
    
    Dim rowReferece As Integer: rowReferece = 2         'rows and columns used to search
    Dim columnReference As Integer: columnReference = 1
    
    Dim duplicated As Integer: duplicated = False
    
    Set pl = ThisWorkbook.Worksheets("BD - Tarifas")
    
    While pl.Cells(plLine, plColumn) <> ""
        While pl.Cells(rowReferece, columnReference) <> ""
        
        rowReferece = rowReferece + 1
        duplicated = False
        columnReference = 1
        
            While pl.Cells(plLine, columnReference) = pl.Cells(rowReferece, columnReference) And pl.Cells(plLine, columnReference) <> ""   'True remains if we get through all columns
                duplicated = True
                columnReference = columnReference + 1
            Wend
        Wend
        
        If (duplicated = True) Then pl.Cells(rowReferece, columnReference).EntireRow.Delete
        
        plLine = plLine + 1
        rowReferece = plLine
        columnReference = 1
    Wend
End Sub

【问题讨论】：

您可以逐行使用WorksheetFunction.CountIf 和WorksheetFunction.CountA 并计算非空白单元格的数量是否等于与第一个单元格中的第一个单元格具有相同值的单元格的数量列。

Here 是我的回答之一，它描述了RemoveDuplicates 的“三个规则”。基本上，你应该使用Columns:=(VBA.Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20))。

【参考方案1】：

删除重复行 (RemoveDuplicates)

当RemoveDuplicates 方法的Columns 参数的参数应该引用多个列时，以下规则适用：

数组必须声明为Variant。 数组必须从零开始。 必须评估数组，例如Evaluate(...) 或只是 (...)。

如果一行单元格中的所有值都相等，则以下内容将删除重复项。

假设数据（表格即一行标题）从单元格A1开始。

Sub removeDupes()
    Dim rg As Range
    Set rg = ThisWorkbook.Worksheets("BD - Tarifas").Range("A1").CurrentRegion
    Dim cUpper As Long: cUpper = rg.Columns.Count - 1
    Dim cData As Variant: ReDim cData(0 To cUpper)
    Dim n As Long
    For n = 0 To cUpper
        cData(n) = n + 1
    Next n
    rg.RemoveDuplicates (cData), xlYes
End Sub

您可以使用范围和Header 作为参数，当您可以重写如下...

Sub removeDupeRows( _
        ByVal rg As Range, _
        Optional ByVal Header As XlYesNoGuess = xlYes)
    If rg Is Nothing Then Exit Sub
    Dim cUpper As Long: cUpper = rg.Columns.Count - 1
    Dim cData As Variant: ReDim cData(0 To cUpper)
    Dim n As Long
    For n = 0 To cUpper
        cData(n) = n + 1
    Next n
    rg.RemoveDuplicates (cData), Header
End Sub

...然后您可以使用它，例如通过以下方式：

Sub removeDupeRowsTEST()
    Dim rg As Range
    Set rg = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
    removeDupeRows rg
End Sub

【参考方案2】：

试试这样的：

Sub DeleteRowMatches()
    
    Dim rng As Range, rw As Range, r As Long, dict, k
    
    Set rng = Selection 'for example - put your table range here
    
    Set dict = CreateObject("scripting.dictionary")
    For r = rng.Rows.Count To 1 Step -1
        Set rw = rng.Rows(r)
        k = Join(Application.Transpose(Application.Transpose(rw.Value)), "~~")
        If dict.exists(k) Then rw.EntireRow.Delete
        dict(k) = True
    Next r

End Sub