Highlight duplicate Rows and filter undu filter and highlight

excel 2003 vba

I need 2 functions to work form 2 command buttons


I have  a sheet that will at any given time have any number of rows...
except row1(column headers A1:AU1)

Duplicate values will be in COLUMN Q

The first command button will highlight the rows in yellow., and show only the rows in yellow via a filter.

2nd command will undo filter

I cannot buy an add-in program.

Thanks
fordraiders

LVL 3
FordraidersAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
rbrhodesConnect With a Mentor Commented:
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



0
 
Michael FowlerSolutions ConsultantCommented:
Will the duplicate rows all be the same value or will there be multiple values duplicated in column Q.

Michael
0
 
FordraidersAuthor Commented:
michael,
dups will be in column Q.

0
Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

 
Rory ArchibaldCommented:
You know you could do this with an additional formula column and an autofilter?
0
 
khan_webguruConnect With a Mentor Commented:
Dealing With Duplicate Records in Microsoft Excel

 Image 1
Finding With a Formula

1. 1

Use this method if you only need to get rid of duplicates once in a while.

1

We insert a new Column A by clicking on A and hitting InsertàColumn.

3

We give the row a heading. If we don't, and we sort the data, we might discombobulate it!

4

We type a formula into A2 that will find duplicates for us. This formula only looks for duplicate values in Column B.
 Image 2
If you need to look for duplicates in more than one column, you can use a formula like this one instead.



 Image 3

If you need to look for duplicates in more than one column, you can use a formula like this one instead.

 Image 4

We now sort descending by Column A to bring all the Dupes to the top.

 Image 5

Select all the rows that have "Dupe" in Column A, and delete them.

Delete Column A.

Finding With Conditional Formatting

Perhaps you only want to find the duplicate values so you can deal with each manually. For this you can use Conditional formatting. Just select the cells you want highlighted if there are duplicates. From the menu, choose FormatàConditional formatting. Choose the options as shown below, and type the formula in as shown, being sure to include the entire range of your cells.


 Image 6
Finding or Highlighting Using VBA

If you need to deal with duplicates often, you'll want to use VBA.

This entry deletes duplicates in a specified range. http://www.vbaexpress.com/kb/getarticle.php?kb_id=135

Chip Pearson provides many ways to deal with duplicates. http://www.cpearson.com/excel/duplicat.htm


I hope this will help you to solve your problem.

Regards,

Asif Ahmed Khan
0
 
khan_webguruCommented:
Hello Bro!

I also found some links that are performing same work that is required by you. Please find the links below:


http://www.excelfunctions.net/Excel-Duplicates.html

http://www.cpearson.com/excel/duplicates.aspx

http://www.ozgrid.com/Excel/highlight-duplicates.htm

http://www.computing.net/answers/office/excel-highlight-duplicate-entries/5159.html

Hope this will help you to solve your problem.

Regards,

Asif Ahmed khan
0
 
Rory ArchibaldCommented:
0
 
FordraidersAuthor Commented:
very nice khan, Thanks
None address a sub routine or function to address my question of adding these behind command buttons or the fact that I will never know the amount of rows at any given time.

0
 
rbrhodesCommented:
0
 
FordraidersAuthor Commented:
Thanks
0
 
FordraidersAuthor Commented:
R B RHODES, just noticed that the "undupe" does not get rid of the colored cells(in "finddupe") ?
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.