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

Question

我正在尝试创建一个子程序，仅当整个行值重复时才删除重复的行（我的工作表有 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

Answer 1

删除重复行 (RemoveDuplicates)

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

  1. 数组必须声明为Variant。
  2. 数组必须从零开始。
  3. 必须评估数组，例如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

Answer 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