Highlight duplicate Rows and filter undu filter and highlight

Hi.

"Can't buy an add in" None available for this, I suppose...

Try this out.  One sub to do it, another to undo it

Option Explicit

Sub FindDupes()

Dim msg
Dim i As Long
Dim roe As Long
Dim col As Long
Dim roe2 As Long
Dim col2 As Long
Dim c As Range
Dim cc As Range
Dim cel As Range
Dim rng As Range
Dim firstaddress As String

    On Error GoTo endo

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Clear old fill
    ActiveSheet.UsedRange.Interior.ColorIndex = xlNone

    'Where to scratch
    roe = ActiveSheet.UsedRange.Rows.Count
    col = ActiveSheet.UsedRange.Columns.Count + 1
    col2 = col + 1

    'Numbers for re-sort
    For i = 1 To 4
        Cells(i + 1, col) = i
    Next i
    Range(Cells(2, col).Address, Cells(5, col).Address).AutoFill _
      Destination:=Range(Cells(2, col).Address, Cells(roe, col).Address), Type:=xlFillDefault

    'Dupe col
    Set rng = Range("Q2:Q" & roe)

    'init
    i = 1
   
    'Check all
    For Each cel In rng
        With rng
            Set c = .Find(cel, LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then
                Set cc = c
                firstaddress = c.Address
                Do
                    'Yellow fill
                    If c.Address <> firstaddress And Cells(c.Row, col2) = "" Then
                        Range(Cells(cc.Row, 1).Address, Cells(cc.Row, "AU").Address).Interior.ColorIndex = 6
                        Range(Cells(c.Row, 1).Address, Cells(c.Row, "AU").Address).Interior.ColorIndex = 6
                        'For dupe sort
                        Cells(c.Row, col2) = i
                        Cells(cc.Row, col2) = i
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstaddress
               
            End If
        End With
        i = i + 1
    Next cel
   
    'Sort on Dupe sort
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(Cells(2, col2).Address, Cells(roe, col2).Address), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range(Cells(2, 1).Address, Cells(roe, col2).Address)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    'Original rows
    roe = Cells(Rows.Count, col).End(xlUp).Row
    'Dupe rows
    roe2 = Cells(Rows.Count, col2).End(xlUp).Row + 1
   
    'No dupes
    If roe2 = 2 Then
        msg = MsgBox("Congratulations, no duplicates found!", vbOKOnly + vbExclamation, "Unique values only")
    Else
        'Hide else
        If roe > roe2 Then
            Rows(roe2 & ":" & roe).EntireRow.Hidden = True
        End If
   
        'Clean up
         Columns(col).Hidden = True
        Columns(col2).Clear
    End If
   
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

    Set c = Nothing
    Set cc = Nothing
    Set cel = Nothing
    Set rng = Nothing

'Completed normally
Exit Sub

'Errored out
endo:
   
    msg = MsgBox("Error " & Err.Description, vbOKOnly + vbCritical, Err.Number)

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

    Set c = Nothing
    Set cc = Nothing
    Set cel = Nothing
    Set rng = Nothing

End Sub

Sub Undupe()

Dim col As Long
Dim roe As Long
   
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Where to scratch
    roe = ActiveSheet.UsedRange.Rows.Count
    col = ActiveSheet.UsedRange.Columns.Count - 1
   
    Columns(col).Hidden = False
    Rows.Hidden = False
   
    'Sort on Dupe sort
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range(Cells(2, col).Address, Cells(roe, col).Address), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range(Cells(1, 1).Address, Cells(roe, col).Address)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Columns(col).Clear
   
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub


http:\\www.members.shae.ca\ExcelVBA