Delete entire row if the same value is found in another cell on the same row

Question

First, I must mention that I am using Excel for Mac, so any code suggestions needs to work for a Mac using Office 365.

I have a large dataset that has nine columns of names. I want to delete the entire row if the same name is in multiple columns in the same row

Example dataset:

So all of these rows would be deleted because:

Jason appears twice in row 1
Jason appears 3 times in row 2
Jason appears 4 times in row 3
Sam appears twice in row 4
Fred appears 3 times in row 5

So no matter how many times a name is repeated in the same row of data, I want to delete that entirerow.

My code is below. This code works but it crashes with a large dataset. I know there has to be a faster, more efficient way to write this code so that it can handle a large dataset. Plus, my code is too repetitive. There has to be a way to make the code more simple. Anyway, here's the code.

'<---- ***** 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

user_1140579 · Answer

Let's say your data looks like this

Code

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

In Action

EDIT

Here is a slower version of the code

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

user_2931864 · Answer

With a Little Research, I found the below function which would remove the duplicates within the same cell.

Function RemoveDupeWords(text As String, Optional delimiter As String = " ") As String
Dim dictionary As Object
Dim x, part

Set dictionary = CreateObject("Scripting.Dictionary")
dictionary.CompareMode = vbTextCompare
For Each x In Split(text, delimiter)
    part = Trim(x)
    If part <> "" And Not dictionary.Exists(part) Then
        dictionary.Add part, Nothing
    End If
Next

If dictionary.Count > 0 Then
    RemoveDupeWords = Join(dictionary.keys, delimiter)
Else
    RemoveDupeWords = ""
End If

Set dictionary = Nothing
End Function

Apply this function as a Formula in the range in which you need the Solution.

RemoveDupeWords(text, [delimiter])

Where:

Text (required) - a string or cell from which you want to delete repeated text. Delimiter (optional) - the delimiter that the repeated text is separated by. If omitted, a space is used for the delimiter. The function is not case-sensitive, meaning that lowercase and uppercase letters are treated as the same characters.

Source: AbleBits

Delete entire row if the same value is found in another cell on the same row

2 Answers