Highlight Duplicate Rows - Entire Row vs Entire Ro

Question

I cant believe how difficult this has been. I want to find all duplicate rows. Columns A:R, dynamic row count. I know how to delete the rows. But I just want to highlight them. My data is in a listobject (table) if that helps. NO! I do not want to use conditional formatting. I have already done that. It works. People always want examples, but I have re-written this so many times, here are the last two I have tried:

Again, my range is x.Range("A4:R380"). Looking how to identify duplicate rows as a whole; not based on a single column or value, etc. All columns in a row. Any help is appreciated. This is more of a learning experience than anything. Office 2010 and Office 2011 (Mac)

    Set rngCl = mySheet.Range("A4:R" + CStr(LastRd))
    Set wf = Application.WorksheetFunction

        For i = 4 To LastRd
        Set cl = rngCl.Rows(i).EntireRow
            If wf.CountIf(rngCl, cl.Value) > 1 Then
            MsgBox "found"
                With cl.Interior
                    .Pattern = xlSolid
                    .PatternThemeColor = xlThemeColorAccent1
                    .Color = 65535
                    .TintAndShade = 0
                    .PatternTintAndShade = 0.799981688894314
                End With
                With cl.Font
                    .Color = -16776961
                    .TintAndShade = 0
                    .Bold = True
                End With
            End If
        Next i

    End Sub



    Sub DuplicateValue()
        Dim Values As Range, iX As Integer
         'set ranges (change the worksheets and ranges to cover where the staterooms are entered
        Set Values = Sheet6.Range("A4:R389")
         con = 0
         con1 = 0
         'checking on first worksheet
        For iX = Values.Rows.Count To 1 Step -1
            If WorksheetFunction.CountIf(Values, Cells(iX, 1).Value) > 1 Then
                con = con + 1
                'MsgBox "Stateroom " & Cells(iX, 1).Address & " has already been issued an iPad!!", vbCritical
                'Cells(iX, 1).ClearContents
            End If
            If WorksheetFunction.CountIf(Values, Cells(iX, 3).Value) > 1 Then
                con1 = con1 + 1
                'MsgBox "This iPAD has already been issued!!", vbCritical
                'Cells(iX, 3).ClearContents
            End If
        Next iX

        MsgBox CStr(con) + ":" + CStr(con1)
    End Sub

Answer 1

Nice morning exercise! ;-)

Here's what I came up with:

Option Explicit

Sub HighlightDuplicates()
    Dim colRowCount As Object

    Dim lo As ListObject
    Dim objListRow As ListRow, rngRow As Range
    Dim strSummary As String

    Set colRowCount = CreateObject("Scripting.Dictionary")

    Set lo = Sheet1.ListObjects(1)

    'Count occurrence of unique rows
    For Each objListRow In lo.ListRows
        strSummary = GetSummary(objListRow.Range)
        colRowCount(strSummary) = colRowCount(strSummary) + 1
    Next

    'Color code rows
    For Each objListRow In lo.ListRows
        Set rngRow = objListRow.Range            
        If colRowCout(GetSummary(rngRow)) > 1 Then
            rngRow.Interior.Color = RGB(255, 0, 0)
        Else
            rngRow.Interior.ColorIndex = RGB(0, 0, 0)
        End If
    Next

End Sub

Function GetSummary(rngRow As Range) As String
    GetSummary = Join(Application.Transpose(Application.Transpose( _
        rngRow.Value)), vbNullChar)
End Function

This will store the count of each unique row in a dictionary - and then check for each row if the count is larger than 1.

Can probably be optimized further (e.g. by storing the summary sting in an array), but should be a good start.