Highlighting duplicate rows

Question

I would like to highlight duplicate rows in Excel VBA. Assume I have the following exemplary table with columns A, B, C and D for testing:

 A       B       C       D (Strings)

 1       1       1       dsf
 2       3       5       dgdgdgdg
 1       1       1       dsf
 2       2       2       xxx
 6       3       4       adsdadad
 2       2       2       xxx

The duplicate rows should be highlighted in any colour, e.g. grey. I am looking ideally for fast performing code, as it will be used for rather big tables. Note there are solutions available for highlighting duplicate cells (but not duplicate rows). I don't know how to identify if rows are duplicates and at the same time how to do that fast, i.e. without nested looping. The solution should be in VBA (not Excel).

What is the best/fastest way to achieve that?

Answer 1

add a conditional formatting with the following sumproduct formula (or a countifs)

=SUMPRODUCT(($A$1:$A$6&$B$1:$B$6&$C$1:$C$6=$A1&$B1&$C1)*1)>1

Explanation:

SUMPRODUCT is handy to work with ranges which you need to manipulate prior to checking a condition. In this case I concatenate A, B & C columns across the range and compare it with the concatenation of the current row. I then convert the TRUE/FALSE array to a 1/0 array by multiplying by 1 and the SUM part of SUMPRODUCT sums the rows where the condition is true, giving me the duplicate rows (all occurences). If you have a small range, using the formula evaluation you can clearly see how this works.

It's a quick fix, but performance is not ideal, I use it a lot for detecting duplicates or generating sequential numbers.

Solution from comments suggested by ponydeer - higher performance

based on sorting suggesting, requires to add key column, put in auto filters and sort on key, then do conditional on key column:

Answer 2

Sort your range first regarding all columns

 Workbooks(1).Sheets(1).Range("A:C").Sort Key1:=Workbooks(1).Sheets(1).Range("A:A"), Order1:=xlAscending, Key2:=Workbooks(1).Sheets(1).Range("B:B"), Order2:=xlAscending, Key3:=Workbooks(1).Sheets(1).Range("C:C"), Order3:=xlAscending, Orientation:=xlSortRows

Then loop through all rows and compare them with the one above them

 Dim a As Application
 Set a = Application

 For i=1 to 1000 ' here you need to set the number of rows you have
   if Join(a.Transpose(a.Transpose(ActiveSheet.Rows(i).Value)), Chr(0)) = _
   Join(a.Transpose(a.Transpose(Sheets(1).Rows(i+1).Value)), Chr(0)) then

      Sheets(1).Range(i+1 & ":" & i+1).EntireRow.Interior.Color = 49407

   end if

 Next i

The comparison of two rows is based on this thread: How to compare two entire rows in a sheet

Please insert the names of your Workbook, Sheet and set your range and the limits in the code yourself.

Answer 3

I have tested 3 different approaches on the sample file link from OP's comment. Probably the VBA implementations were not optimal, but below are the results with average time of 100 passes:

1) Conditional formatting using:

a)SUMPRODUCT concatenating columns - 3s

b) COUNTIFS with full column reference - 1.9s

c) COUNTIFS referencing used ranges - 0.2s

2) Sorting the range on all columns, comparing row by row, sorting back - 0.3s

3) Using advanced filter 3.5s

Here is the code for the fastest method:

Sub CF1()

    Application.ScreenUpdating = False

    Dim sFormula As String
    Dim rRng As Range
    Dim nCol As Integer, i As Integer

    Set rRng = Range("A1").CurrentRegion
    nCol = rRng.Columns.Count

    'build the formula
    sFormula = "=COUNTIFS("

    For i = 1 To nCol
      sFormula = sFormula & rRng.Columns(i).Address & "," & _
         rRng.Cells(1, i).Address(False, True)
      If i < nCol Then sFormula = sFormula & ","
    Next
    sFormula = sFormula & ")>1"

    'write the formula in helper cell to get it's local version
    rRng.Cells(1, nCol + 1).Formula = sFormula

    rRng.FormatConditions.Delete
    With rRng.FormatConditions.Add(Type:=xlExpression, _
            Formula1:=rRng.Cells(1, nCol + 1).FormulaLocal)
       .Interior.ThemeColor = xlThemeColorAccent3
    End With

    rRng.Cells(1, nCol + 1).Clear

    Application.ScreenUpdating = True
End Sub

Answer 4

I think fastest/best will depend upon the proportion of duplicates – only one row should be quicker than 50% as in the example – and on the actual size of the array (how many columns from which to create a key, etc).

Given that it is rarely possible to beat inbuilt functions with ‘pure’ VBA I suspect using the UI, within VBA if desired, will be faster in some circumstances. Eg:

Add an index column (series fill would serve), copy entire sheet (say to Sheet2), apply Remove Duplicates to all but index column, then apply as CF formula rule of this kind the relevant range of the original sheet:

=$A1=MATCH($A1,Sheet2!$A$1:$A$3000,0)>0  

---

Assuming the start point is like so:

and a ColumnA inserted with numeric series fill starting 1, Sheet2 should look so after Remove Duplicates:

I have assumed ColumnE is to be ignored as far as duplication is concerned.

In source sheet, select array (from A1: - see!), eg A1:I6 and HOME >Styles - Conditional Formatting, New Rule..., Use a formula to determine which cells to format, Format values where this formula is true::

=$A1=MATCH($A1,Sheet2!$A:$A,0)>0  

Format..., Fill, grey, OK, OK.

For me results in:

Answer 5

Sub HighlightDuplicateRows_2()

  'This one is more modifiable and can handle multiple columns of data
  'Just add another *WorksheetFunction.CountIf(Range("A2:A" & LastRow),Cells(r,1).Value) > 1* and change the column values

  Dim LastRow As Long

  LastRow = Cells(Rows.Count, "A").End(xlUp).Row

  For r = 2 To LastRow

    If WorksheetFunction.CountIf(Range("A2:A" & LastRow), Cells(r, 1).Value) > 1 And WorksheetFunction.CountIf(Range("B2:B" & LastRow), Cells(r, 2).Value) > 1 Then
    Rows(r).Interior.ColorIndex = 6
    End If

  Next r

End Sub