excel - 如果在同一行的另一个单元格中找到相同的值，则删除整行

Question

首先，我必须说明我正在使用 Mac 版 Excel，因此任何代码建议都需要适用于 使用 Office 365 的 Mac。

我有一个包含九列名称的大型数据集。如果同一行的多个列中有相同的名称，我想删除整行

示例数据集:

所以所有这些行都将被删除，因为:

1. Jason 在 1 行中出现 两次
2. Jason 在 2 行中出现 3 次
3. Jason 在 3 行中出现 4 次
4. Sam 在 4 行中出现 两次
5. Fred 在 5 行中出现 3 次

所以无论同一行数据中一个名字重复了多少次，我都想删除整行。

我的代码如下。此代码有效，但它会因大型数据集而崩溃。我知道必须有一种更快、更有效的方法来编写此代码，以便它可以处理大型数据集。另外，我的代码太重复了。必须有一种方法可以使代码更简单。不管怎样，这是代码。

'<---- ***** DELETE ANY ROWS WHERE SAME NAME APPEARS TWICE (OR MORE) IN THAT ROW

Sub RemoveDuplicateRows()
    Dim Lastrow As Long
    Dim Lrow As Long

    Lastrow = Range("A" & Rows.Count).End(xlUp).row
    For Lrow = Lastrow To 2 Step -1
        If Cells(Lrow, "A").Value = Cells(Lrow, "B").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "A").Value = Cells(Lrow, "C").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "A").Value = Cells(Lrow, "D").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "A").Value = Cells(Lrow, "E").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "A").Value = Cells(Lrow, "F").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "A").Value = Cells(Lrow, "G").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "A").Value = Cells(Lrow, "H").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "A").Value = Cells(Lrow, "I").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "B").Value = Cells(Lrow, "C").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "B").Value = Cells(Lrow, "D").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "B").Value = Cells(Lrow, "E").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "B").Value = Cells(Lrow, "F").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "B").Value = Cells(Lrow, "G").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "B").Value = Cells(Lrow, "H").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "B").Value = Cells(Lrow, "I").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "C").Value = Cells(Lrow, "D").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "C").Value = Cells(Lrow, "E").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "C").Value = Cells(Lrow, "F").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "C").Value = Cells(Lrow, "G").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "C").Value = Cells(Lrow, "H").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "C").Value = Cells(Lrow, "I").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "D").Value = Cells(Lrow, "E").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "D").Value = Cells(Lrow, "F").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "D").Value = Cells(Lrow, "G").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "D").Value = Cells(Lrow, "H").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "D").Value = Cells(Lrow, "I").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "E").Value = Cells(Lrow, "F").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "E").Value = Cells(Lrow, "G").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "E").Value = Cells(Lrow, "H").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "E").Value = Cells(Lrow, "I").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "F").Value = Cells(Lrow, "G").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "F").Value = Cells(Lrow, "H").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "F").Value = Cells(Lrow, "I").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "G").Value = Cells(Lrow, "H").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "G").Value = Cells(Lrow, "I").Value Then
             Cells(Lrow, "A").EntireRow.Delete
        ElseIf Cells(Lrow, "H").Value = Cells(Lrow, "I").Value Then
                Cells(Lrow, "A").EntireRow.Delete
        End If
    Next Lrow
End Sub

Answer 1

假设您的数据如下所示

代码

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim Ar As Variant
    Dim lRow As Long, lCol As Long
    Dim i As Long, j As Long, k As Long, l As Long
    
    '~~> Set this to the relevant sheet
    Set ws = Sheet1
    
    With ws
        If Application.WorksheetFunction.CountA(.Cells) = 0 Then Exit Sub
        
        '~~> Find last row and column
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
                      
        lCol = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Column
        
        '~~> Get the data into an array
        Ar = .Range(.Cells(1, 1), .Cells(lRow, lCol))
    End With
    
    '~~> Clear the rows in an array for the required condition
    Application.StatusBar = "Processing Array"
    DoEvents

    For i = LBound(Ar) To UBound(Ar)
        For j = 1 To lCol
            For k = 2 To lCol
                '~~> An additional check to see if the compared cell is not blank
                If Ar(i, j) = Ar(i, k) And Len(Trim(Ar(i, 1))) <> 0 And j <> k Then
                    For l = 1 To lCol: Ar(i, l) = "": Next l
                    Exit For
                End If
            Next k
        Next j

        Application.StatusBar = "Processing row " & i & " of " & UBound(Ar)
        DoEvents
    Next i
    
    Dim delRange As Range
    
    With ws
        '~~> Clear data for output
        .Cells.Clear
        '~~> Get the data back in the worksheet
        .Range("A1").Resize(lRow, lCol).Value = Ar
        
        If Application.WorksheetFunction.CountA(.Cells) = 0 Then Exit Sub
        
        '~~> Find the new last row
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
        
        '~~> Check for blank rows
        For i = 1 To lRow
            If Application.WorksheetFunction.CountA(.Range(.Cells(i, 1), .Cells(i, lCol))) = 0 Then
                If delRange Is Nothing Then
                    Set delRange = .Rows(i)
                Else
                    Set delRange = Union(delRange, .Rows(i))
                End If
            End If

            Application.StatusBar = "Checking row " & i & " of " & lRow & " for blanks"
            DoEvents
        Next i
        
        '~~> If blank rows found then delete them in one go
        If Not delRange Is Nothing Then delRange.Delete shift:=xlUp
    End With

    Application.StatusBar = "Ready"
    DoEvents
End Sub

在行动

---

编辑

这是一个较慢版本的代码

Option Explicit

Sub Sample()
    Dim ws As Worksheet
    Dim lRow As Long, lCol As Long
    Dim i As Long, j As Long
    Dim delRange As Range
    
    '~~> Set this to the relevant sheet
    Set ws = Sheet1
    
    With ws
        If Application.WorksheetFunction.CountA(.Cells) = 0 Then Exit Sub
        
        '~~> Find last row and column
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
                      
        lCol = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Column
    
    
        '~~> Clear the rows in an array for the required condition
        Application.StatusBar = "Processing Rows"
        DoEvents
    
        For i = 1 To lRow
            For j = 1 To lCol
                If Len(Trim(.Cells(i, j).Value2)) <> 0 Then
                    If Application.WorksheetFunction.CountIf(.Rows(i), .Cells(i, j).Value2) > 1 Then
                        .Rows(i).ClearContents
                        Exit For
                    End If
                End If
            Next j
    
            Application.StatusBar = "Processing row " & i & " of " & lRow
            DoEvents
        Next i
        
        If Application.WorksheetFunction.CountA(.Cells) = 0 Then Exit Sub
        
        '~~> Find the new last row
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
        
        '~~> Check for blank rows
        For i = 1 To lRow
            If Application.WorksheetFunction.CountA(.Range(.Cells(i, 1), .Cells(i, lCol))) = 0 Then
                If delRange Is Nothing Then
                    Set delRange = .Rows(i)
                Else
                    Set delRange = Union(delRange, .Rows(i))
                End If
            End If

            Application.StatusBar = "Checking row " & i & " of " & lRow & " for blanks"
            DoEvents
        Next i
        
        '~~> If blank rows found then delete them in one go
        If Not delRange Is Nothing Then delRange.Delete shift:=xlUp
    End With

    Application.StatusBar = "Ready"
    DoEvents
End Sub