Highlight equal row text

[Manolocs]

Hello, How to Highlight two consecutive equal text cells in a table ? I have to find, identify and manually delete multiple rows of an extensive table with 5 columns, the search for consecutive identical rows is needed by the column "A" only, the other columns maybe not equal. I tried already with conditional formatting but while I am deleting the entire row, the conditional missed a lot of identical cells.
Any idea how to make it easier?
Thanks in advance.

 

[Fishboy]

Hello, How to Highlight two consecutive equal text cells in a table ? I have to find, identify and manually delete multiple rows of an extensive table with 5 columns, the search for consecutive identical rows is needed by the column "A" only, the other columns maybe not equal. I tried already with conditional formatting but while I am deleting the entire row, the conditional missed a lot of identical cells.
Any idea how to make it easier?
Thanks in advance.

Hi Manolocs,

You could use the following macro to highlight the duplicate rows:

Sub RemoveDupes()
' Defines variables
Dim x As Long, LastRow As Long, cRange As Range


' Defines LastRow as the last row of data based on column A
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row


' Sets the check range as A1 to the last row of A
Set cRange = Range("A1:A" & LastRow)


' For each cell in the check range, working from the bottom upwards
For x = cRange.Cells.Count To 1 Step -1
    With cRange.Cells(x)
        ' If the count of the cell value is more than 1 then...
        If Application.WorksheetFunction.CountIf(cRange, .Value) > 1 Then
            ' Highlight the row with yellow fill
            .EntireRow.Interior.ColorIndex = 6
        End If
    End With
' Check next cell in check range
Next x


End Sub

Or better yet to save manually removing the duplicates this slightly modified version of the code above will directly remove one of the duplicates instead of just highlight it:

Sub RemoveDupes()
' Defines variables
Dim x As Long, LastRow As Long, cRange As Range


' Defines LastRow as the last row of data based on column A
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row


' Sets the check range as A1 to the last row of A
Set cRange = Range("A1:A" & LastRow)


' For each cell in the check range, working from the bottom upwards
For x = cRange.Cells.Count To 1 Step -1
    With cRange.Cells(x)
        ' If the count of the cell value is more than 1 then...
        If Application.WorksheetFunction.CountIf(cRange, .Value) > 1 Then
            ' Delete that row
            .EntireRow.Delete
        End If
    End With
' Check next cell in check range
Next x


End Sub

 

[Manolocs]

Hi FishBoy, I got an error in this line:

"If Application.WorksheetFunction.CountIf(cRange, .Value) > 1 Then"

Run-time error '1004'
Method 'Countif' of object 'WorksheetFunction failed

Sorry I am not familiar with macros

 

[Fishboy]

Hi FishBoy, I got an error in this line:

"If Application.WorksheetFunction.CountIf(cRange, .Value) > 1 Then"

Run-time error '1004'
Method 'Countif' of object 'WorksheetFunction failed

Sorry I am not familiar with macros

Hmm, are we dealing with a single sheet here? Or at least one at a time? How many rows are in your tables? Are the tables completely consecutive or is there a gap between the two?

 

[Manolocs]

there is only one sheet, and the rows are consecutives and sorted A-Z no gaps, there are more than thousands lines

 

[Fishboy]

there is only one sheet, and the rows are consecutives and sorted A-Z no gaps, there are more than thousands lines

Hmm, download my test document HERE and let me know if you get the error. If you don't then there is something about your set up that is different.

 

[Manolocs]

Yours is working but is not deleting all of them.... at the end of the run still have 27 rows....
I would prefer your first example. then I can chose the ones I need to delete because I will delete according with the other columns.... the "A" collumn is only to show the rows that have the first column the same.

 

[Fishboy]

Yours is working but is not deleting all of them.... at the end of the run still have 27 rows....
I would prefer your first example. then I can chose the ones I need to delete because I will delete according with the other columns.... the "A" collumn is only to show the rows that have the first column the same.

There should have only been 26 rows left (A through Z) as the code was purposefully only deleting 1 of the duplicates if more than 1 were counted. Even if there had been 6 of the same thing, you would have ended up with only 1 of them at the end.

To tweak my code to highlight instead see the updated version below:

Sub RemoveDupes()
' Defines variables
Dim x As Long, LastRow As Long, DupeCount As Long, cRange As Range


' Defines LastRow as the last row of data based on column A
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row




' Sets the check range as A1 to the last row of A
Set cRange = Range("A1:A" & LastRow)


' Sets DupeCount to zero
DupeCount = 0


' Update status bar
Application.StatusBar = "Highlighting Duplicates...Please Wait"


' Disables screen updating to reduce flicker
Application.ScreenUpdating = False


' For each cell in the check range, working from the bottom upwards
For x = cRange.Cells.Count To 1 Step -1
    With cRange.Cells(x)
        ' If the count of the cell value is more than 1 then...
        If Application.WorksheetFunction.CountIf(cRange, .Value) > 1 Then
            ' Highlight that row with yellow fill
            .EntireRow.Interior.ColorIndex = 6
            DupeCount = DupeCount + 1
        End If
    End With
' Check next cell in check range
Next x


' Re-enables screen updating
Application.ScreenUpdating = True


' Update status bar
Application.StatusBar = "Task Complete"


' Optional message box confirming task is complete
MsgBox DupeCount & " Duplicates Highlighted", vbOKOnly, "Task Complete!"


End Sub

 

[Manolocs]

now the error is back, I updated your code to your spreadsheet and the error is the same...

 

[Fishboy]

now the error is back, I updated your code to your spreadsheet and the error is the same...

Strange, everything is still working HERE at my end, even with the updated code.