Solved

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

Posted on 2011-02-16
8
455 Views
Last Modified: 2012-08-14
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.
0
Comment
Question by:stormitex
  • 3
  • 2
  • 2
  • +1
8 Comments
 
LVL 12

Expert Comment

by:sstampf
ID: 34913458
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

0
 
LVL 41

Expert Comment

by:dlmille
ID: 34913577
@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

0
 
LVL 12

Expert Comment

by:sstampf
ID: 34913850
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.
0
 
LVL 50

Accepted Solution

by:
barry houdini earned 250 total points
ID: 34914883
You can do this with "regular" conditional formatting without VBA if you want. I think it's robust enough to withstand sorting and/or deleting rows but it might depend exactly how you do that, e.g. deleting 2 rows in the middle of the range will be OK, deleting all the conditionally formatted rows won't be.

I put dates in A2:A100 (with some blanks to see what happens to those) and used this formula for the top 10 (latest different dates)

=SUMPRODUCT((A$2:A$100>A2)/COUNTIF(A$2:A$100,A$2:A$100&""))<10

and this formula for the bottom 10

=(SUMPRODUCT((A$2:A$100<A2)*(A$2:A$100<>"")/COUNTIF(A$2:A$100,A$2:A$100&""))<10)*(A2<>"")

see attached

You can press F9 to re-generate random dates to see how the conditional formatting changes, these will all be within a 100 day period so there will normally be some duplicates..........

Note that theoretically you only need SUM rather than SUMPRODUCT in these formulas but in practice in Excel 2007, in which I'm working, using any formulas in conditional formatting that would need "array entering" if they were on the worksheeet causes problems when the workbook is re-opened (CF doesn't update correctly)

regards, barry
26827591.xlsx
0
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 41

Expert Comment

by:dlmille
ID: 34917622
@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
0
 
LVL 50

Expert Comment

by:barry houdini
ID: 34920169
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
0
 
LVL 41

Expert Comment

by:dlmille
ID: 34920895
@Barry-you are indeed the formula wizard.  Thanks, I'll tuck that away in my knowledgebase!

Dave
0
 

Author Closing Comment

by:stormitex
ID: 34921856
Barry.....one word.....Genius!!
Thanks heaps!

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

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.

911 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now