根据值删除重复项

Question

如果满足这些条件，我的代码将删除整行：

1. ID 重复并且
2. 在重复 ID 中，cond1 = Hello AND
3. 在重复 ID 中，cond2 = 1

请参阅下面的示例表。突出显示的应该被删除。 代码很慢，因此找到了优化它的方法。

Sub RemoveDupl()

    'to check if the Incident ID has duplicates
    lastRow = Worksheets("Sheet1").Cells(Rows.Count, 6).End(xlUp).Row
    
    'loop to check all the rows
    For i = 2 To lastRow
        Set rangeIDCheck = Range("A:A")
        For j = 2 To lastRow
            If WorksheetFunction.CountIf(rangeIDCheck, Worksheets("Sheet1").Cells(j, 6).Value) > 1 And Worksheets("Sheet1").Cells(j, 15).Value = "Hello" And Worksheets("Sheet1").Cells(j, 16).Value = "1" Then
                Rows(j).EntireRow.Delete
            End If
        Next
    Next

End Sub

我的第二个代码。我只需要如何获取当前行号。我搜索但一无所获。 * 里面是我需要更换的那个。

Sub RemoveDupl()
        
    'turning off
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    Dim Rng As Range
    Dim cel As Range
    Dim Counter As Integer

    Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
        
    For Each cel In Rng
        If WorksheetFunction.CountIf(Rng, cel.Value) > 1 And Cells(**Rng.Row**, 15) = "Hello" And Cells(**Rng.Row**, 16) = "1" Then
            cel.EntireRow.Delete
            'cel.EntireRow.Interior.Color = 5296274
        End If
    Next cel

    'turning on
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Answer 1

小幅修正后更新（感谢EEM）

对于您的第一个代码，您可以通过在最后一次全部删除来加快速度。试试这个....

Sub RemoveDupl()
Dim WS As Worksheet: Set WS = Sheets("Sheet1")

'to check if the Incident ID has duplicates
lastRow = WS.Cells(Rows.Count, 6).End(xlUp).Row


'loop to check all the rows
Dim aRng As Range

Set aRng = WS.Rows(Rows.Count)

For i = 2 To lastRow
    Set rangeIDCheck = WS.Range("A:A")
        For j = 2 To lastRow
            If WorksheetFunction.CountIf(rangeIDCheck, WS.Cells(j, 6).Value) > 1 And WS.Cells(j, 15).Value = "Hello" And WS.Cells(j, 16).Value = "1" Then
                Rows(j).EntireRow.Delete

                Set aRng = Union(aRng, Rows(j))

            End If
        Next
Next
aRng.ClearContents
aRng.Delete
End Sub

对于您的第二个代码，您可以将行作为属性获取。所以你的代码会这样写：

WorksheetFunction.CountIf(Rng, cel.Value) > 1 And Cells(cel.Row, 15) = "Hello"  _ 
And Cells(cel.Row, 16) = "1" Then

希望有效。