Link to home
Start Free TrialLog in
Avatar of stormitex
stormitex

asked on

Excel 2010, Highlight Unique top 10 and bottom 10 dates in column

Hi, as per the title...

I have a list of 80 dates that I would like to highlight the top 10 unique values.  It is the 'unique' part I am having a problem with as there a multiple entries with the same date.  I would like all entries with the same date to only be recognised as only 1 value within the top 10.  So there could be 18 of the 80 dates that fall within the top ten highest date range.   Then I want to be able to highlight the 18 entries.  Similar issue with the bottom 10.  The worksheet has two separate macros to sort by two different columns so the cells will move per the sorting rules and rows are deleted and added as required.  I would like not have to re-enter the formulas each time a row is deleted or added.
Avatar of sstampf
sstampf
Flag of India image

Try this code and let me know if you have any questions.

Shashank
Sub Macro1()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range
    Dim i As Integer, lstRow As Long
    Set ws1 = ActiveSheet
    Set rng1 = Application.InputBox("Select Target Column", , , , , , , 8)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheets.Add
    Set ws2 = ActiveSheet
    rng1.Copy
    ActiveSheet.Paste
    ActiveSheet.Range("$A$1:$A" & Rows.Count).RemoveDuplicates Columns:=1, Header:=xlGuess
    ws2.Sort.SortFields.Clear
    ws2.Sort.SortFields.Add Key:=Range("A1:A" & Rows.Count) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws2.Sort
        .SetRange Range("A1:A" & Rows.Count)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    lstRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
    ws1.Activate
    For i = 1 To 10
    rng1.Select
    Selection.Find(What:=CDate(ws2.Range("A" & i).Value), After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Select
       Selection.Interior.Color = vbYellow
    Next i
    For i = (lstRow - 10) To lstRow
    rng1.Select
    Selection.Find(What:=CDate(ws2.Range("A" & i).Value), After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Select
       Selection.Interior.Color = vbGreen
    Next i
    ws2.Delete
    Application.CutCopyMode = False
    Set rng1 = Nothing
    Set ws1 = Nothing
    Set rng2 = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Open in new window

@sstampf - good tip - I tried to do this with conditional formatting and the results weren't consistent at all!  

However - one error, I believe, in your code (unless I'm counting wrong, this tested with data in attached...  Gives 11 greens, unless you make the following change:

The second loop should be:

    For i = (lstRow - 9) To lstRow 'lstRow -9 not lstRow-10    
    rng1.Select
    Selection.Find(What:=CDate(ws2.Range("A" & i).Value), After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Select
       Selection.Interior.Color = vbGreen
    Next i
12/6/2008
12/6/2008
12/6/2008
12/6/2008
12/6/2008
12/6/2008
12/6/2008
12/6/2008
12/6/2008
12/6/2008
12/6/2008
9/1/1990
4/20/2000
6/25/1995
11/5/2001
1/15/2000
12/14/2008
11/11/2006
1/23/1998
7/26/1995
2/9/1992
12/16/1990
12/2/1995
10/9/1991
8/13/1991
8/30/1993
8/2/2003
8/8/2007
10/24/1995
11/20/2000
6/5/1997
1/9/1999
6/8/2003
3/29/2000
6/14/2001
3/8/1998
8/17/1991
1/29/1994
4/24/1996
11/8/1995
10/7/1998
9/16/1991
11/28/1997
11/19/2007
9/17/2003
2/20/2005
4/18/2007
5/26/2005
9/19/1996
3/16/1990
1/21/2006
1/13/2011
5/16/2006
1/22/1991
3/30/2008
7/2/2010
2/6/2002
6/1/2003
11/14/1991
10/3/1995
11/25/1996
4/16/2005
11/3/1999
3/15/1999
9/13/2003
1/14/2004
11/12/1992
11/1/2001
4/25/1997
5/11/1995
12/27/2010
9/9/2004
11/9/2004
5/23/1992
4/24/1990
10/16/2004
11/5/1990
1/23/1994
12/4/1992
1/6/2009
1/31/2003
1/10/1998
1/7/2003
7/26/2008
6/28/1996
11/12/1990
7/29/2006
2/15/2006
9/29/1995
9/30/1997
4/15/2009
9/8/2008
7/17/2001
11/13/1991
7/5/2001

Open in new window

Good catch dlmille. Thanks for suggesting this improvement.

@stormitex, I want to point out that I didn't included headers in my test data set while building this code so if your data set has headers you may want to change line no 27 of my code to say:
for i=2 to 11

Let me know if you have any questions/concerns.
ASKER CERTIFIED SOLUTION
Avatar of barry houdini
barry houdini
Flag of United Kingdom of Great Britain and Northern Ireland image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
@Barry, I knew there had to be a conditional formatting solution, but at the time, I couldn't get my mind to think in SUMPRODUCT mode :)

I get it - but, what does the &"" do for the formula?
and, why did the bottom 10 need the additional (A2<>"") as opposed to the top 10?

Dave
Hello Dave,

The &"" makes the formula work correctly if the range includes blanks.

If you try this formula on the worksheet

=COUNTIF(A1:A10,A1:A10)

then that returns an array of ten values, and if any cell in A1:A10 is blank the corresponding value is zero, which is a problem in the larger formula because we are diving by the COUNTIF result, so any zeroes will lead to a #DIV/0! error. The fix is to use

=COUNTIF(A1:A10,A1:A10&"")

because now any blanks in A1:A10 will result in a return of 1

blank cells will also be formatted as part of the bottom 10 (because they are deemed to be zeroes) so you need to explicitly exclude those with the extra condition, A2<>""

regards, barry
@Barry-you are indeed the formula wizard.  Thanks, I'll tuck that away in my knowledgebase!

Dave
Avatar of stormitex
stormitex

ASKER

Barry.....one word.....Genius!!
Thanks heaps!

Thanks for the code too sstampf.  Conditional formatting makes life much more simpler.