Highlighting the 5 Largest Numbers in a list

[manoshde]

Hi all,

I have a Score column that runs into many entries.

Is there a way to highlight the top 5 scores on the list in different
colours.

Conditional format permits me to highlight the three largest only (yes
another gripe on this much needed excel feature!)

Any help is appreciated in advance!!

Regards
Manosh

 

[Don Guillett]

Does this help?

Sub highlightlargest()
lr = Cells(Rows.Count, "e").End(xlUp).Row
rng = Range("e2:e" & lr)
With Columns(5)
..Interior.ColorIndex = 0
..Find(Application.Large(rng, 1)).Interior.ColorIndex = 4
..Find(Application.Large(rng, 2)).Interior.ColorIndex = 5
'etc
End With
End Sub

 

[Guest]

Say your data goes from A1 thru A100

Set the conditional format for A1 to be:

Formula Is
=(A1>LARGE(A$1:A$100,6))
with a hi-lighted format
and copy the format down the column

The top 5 items will be hi-lighted

 

[Don Guillett]

different colours.

 

[manoshde]

Thanks for your reply Don

Apologies for the duplicate posting.

i understand how the code may be extended for n etc numbers to be
highlighted different colours.

However, where do i enter this code? is it in the view code area of the
worksheet?

regards
manosh

 

[Paul B]

Manosh, the code that Don provided need to go in a module not in the sheet
code

To put in this macro, from your workbook right-click the workbook's icon and
pick View Code. This icon is to the left of the "File" menu this will open
the VBA editor, in Project Explorer click on your workbook name, if you
don't see it press CTRL + r to open the Project Explorer, then go to insert,
module, and paste the code in the window that opens on the right hand side,
press Alt and Q to close this window and go back to your workbook and press
alt and F8, this will bring up a box to pick the Macro from, click on the
Macro name to run it. If you are using excel 2000 or newer you may have to
change the macro security settings to get the macro to run. To change the
security settings go to tools, macro, security, security level and set it to
medium


--
Paul B
Always backup your data before trying something new
Please post any response to the newsgroups so others can benefit from it
Feedback on answers is always appreciated!
Using Excel 2002 & 2003

 

[manoshde]

Thanks Paul

This works great when you run the macro.

However, the beauty of the conditional format was that it was 'live'

How can this code be run automatically to reflect anychanges to the
sheet automatically?

Regards
M

 

[L. Howard Kittle]

Hi Manosh,

This will make it 'live'. I used it in the worksheet module and it works
fine.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Integer
Dim rng As Range

lr = Cells(Rows.Count, "e").End(xlUp).Row
Set rng = Range("e2:e" & lr)
With Columns(5)
..Interior.ColorIndex = 0
..Find(Application.Large(rng, 1)).Interior.ColorIndex = 4
..Find(Application.Large(rng, 2)).Interior.ColorIndex = 5
'etc
End With
End Sub

HTH
Regards,
Howard

 

[L. Howard Kittle]

This has an error checker.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr As Integer
Dim rng As Range

lr = Cells(Rows.Count, "e").End(xlUp).Row
Set rng = Range("e2:e" & lr)
On Error GoTo nope

With Columns(5)
..Interior.ColorIndex = 0
..Find(Application.Large(rng, 1)).Interior.ColorIndex = 4
..Find(Application.Large(rng, 2)).Interior.ColorIndex = 5
'etc
End With

nope:
End Sub

 

[manoshde]

Once again thanks Howard for the prompt reply on this forum.

On using this i have found that when there are two equal values (or
same rank) the formula only highlights the first occurance. Can this be
corrected?

To easier computing!
M

 

[manoshde]

Hi Howard

Thanks again for your help

This error checker still highlights only the first occurance. It should
highlight ALL occurances of the same rank. Is this possible in excel?

m

 

[L. Howard Kittle]

Hmmm, I'll give it some thought. Hopefully, Don G. is still monitoring this
thread, I'm sure he can whip one out in a sec.

Regards,
Howard

 

[manoshde]

Thanks Howard.

Conditional format takes care of this quite easily on the fly.

Another reason for MS to support upto 10 conditional formats(!

Look fwd to your workaround.

regards
m

 

[L. Howard Kittle]

Here's an attempt to catch ties. The colors are inconsistent when there are
multiple ties. So, if it is important that the rank and color are always
the same, then this won't work for you. It does seem to always color the 5
highest.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim i As Integer
Dim lr As Integer
Dim rng As Range
Dim Cell As Range

lr = Cells(Rows.Count, "e").End(xlUp).Row
Set rng = Range("e2:e" & lr)
rng.Interior.ColorIndex = 0

For Each Cell In rng

If Cell.Value = Application.Large(rng, 1) Then

Cell.Interior.ColorIndex = 5 ' dark blue
End If

If Cell.Value = Application.Large(rng, 2) Then
Cell.Interior.ColorIndex = 4 ' green
End If

If Cell.Value = Application.Large(rng, 3) Then
Cell.Interior.ColorIndex = 6 ' yellow
End If

If Cell.Value = Application.Large(rng, 4) Then
Cell.Interior.ColorIndex = 7 'viloet
End If

If Cell.Value = Application.Large(rng, 5) Then
Cell.Interior.ColorIndex = 8 'light blue
End If

Next

End Sub

Regards,
Howard

 

[manoshde]

This is turning out to be an interesting exercise

Now there is a Run Time Error '13 Type Mismatch when there are no
numbers and i start to enter them one by one.

For example, if the code is already in the sheet, and the numbers start
to be put in the cell the error box pops up when Enter is pressed on
the first cell with a new number (all the other cells in the range are
currently blank).

Ideally this error should not appear... and yet the code should be
'live'. This would be most useful for novice user like us!

I am running out of thank yous!

regards
manosh

 

[L. Howard Kittle]

I see.

Sorry, that's my best shot at it. I'm sure the answer is not all that
complicated, but it's off my screen.

If you get a solution would you please send me a copy.

[email protected]
Regards,
Howard

 

[Bryan Hessey]

A slight mod to the code supplied by L. Howard Kittle to remove errors,
and to allow for the last (few) figures being deleted.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim i As Integer
Dim lr As Integer
Dim rng As Range
Dim Cell As Range

lr = Cells(Rows.Count, "e").End(xlUp).Row
Set rng = Range("e2:e" & lr + 200)
rng.Interior.ColorIndex = 0 ' clear beyond last

Set rng = Range("e2:e" & lr)

For Each Cell In rng
On Error Resume Next

If Cell.Value = Application.Large(rng, 1) Then

Cell.Interior.ColorIndex = 5 ' dark blue
Else

If Cell.Value = Application.Large(rng, 2) Then
Cell.Interior.ColorIndex = 4 ' green
Else

If Cell.Value = Application.Large(rng, 3) Then
Cell.Interior.ColorIndex = 6 ' yellow
Else

If Cell.Value = Application.Large(rng, 4) Then
Cell.Interior.ColorIndex = 7 'viloet
Else

If Cell.Value = Application.Large(rng, 5) Then
Cell.Interior.ColorIndex = 8 'light blue
Else
End If
End If
End If
End If
End If

NextCell:
On Error GoTo 0

Next

End Sub


Hope this helps

 

[Bryan Hessey]

I have just read your post on Blank cells, and if you intend to have
blank cells and less than 5 (high) figures then you would need to add
code to accomodate this, the lines to be added are:

-For Each Cell In rng
On Error Resume Next-

*If Cell.Value = "" Then

Else*-
If Cell.Value = Application.Large(rng, 1) Then-

add the bold lines where shown, and add another 'End If' to the
collection.

If needed the full code is attached at:


http://www.excelforum.com/attachment.php?attachmentid=4638&d=1145179806

==

A slight mod to the code supplied by L. Howard Kittle to remove errors,
and to allow for the last (few) figures being deleted.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim i As Integer
Dim lr As Integer
Dim rng As Range
Dim Cell As Range

lr = Cells(Rows.Count, "e").End(xlUp).Row
Set rng = Range("e2:e" & lr + 200)
rng.Interior.ColorIndex = 0 ' clear beyond last

Set rng = Range("e2:e" & lr)

For Each Cell In rng
On Error Resume Next

If Cell.Value = Application.Large(rng, 1) Then

Cell.Interior.ColorIndex = 5 ' dark blue
Else

If Cell.Value = Application.Large(rng, 2) Then
Cell.Interior.ColorIndex = 4 ' green
Else

If Cell.Value = Application.Large(rng, 3) Then
Cell.Interior.ColorIndex = 6 ' yellow
Else

If Cell.Value = Application.Large(rng, 4) Then
Cell.Interior.ColorIndex = 7 'viloet
Else

If Cell.Value = Application.Large(rng, 5) Then
Cell.Interior.ColorIndex = 8 'light blue
Else
End If
End If
End If
End If
End If

NextCell:
On Error GoTo 0

Next

End Sub


Hope this helps

--

+-------------------------------------------------------------------+
|Filename: Code.txt |
|Download: http://www.excelforum.com/attachment.php?postid=4638 |
+-------------------------------------------------------------------+

 

[Guest]

If you want the first 5 UNIQUE largest numbers then try this:

Sub b()
Dim Cell As Range

lr = Cells(Rows.Count, "e").End(xlUp).Row
Set rng = Range("e2:e" & lr + 200)
rng.Interior.ColorIndex = 0 ' clear beyond last

Set rng = Range("e2:e" & lr)
i = 1
For j = 1 To 5
With rng
Set c = .Find(Application.Large(rng, i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
n = Application.CountIf(rng, Application.Large(rng, i))
Do
c.Interior.ColorIndex = j + 3
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
i = i + n
Next j
End Sub

 

[Don Guillett]

I create a helper column and use that in the findnext
It works but could probably be better.
Assumes data in col E and helper col in col L (could be hidden)

Sub HiglightLargestFiveUnique() 'with helper column
Cells(1, "l").Value = Application.Max(Range("e2:e500"))
For i = 2 To 5
Cells(i, "l").FormulaArray = _
"=max(if(e2:e500<l" & i - 1 & ",e2:e500))"
Next i

Columns(5).Interior.ColorIndex = 0
On Error Resume Next
ci = 33
For Each cel In Range("l1:l5")
With Range("e2:e" & Cells(Rows.Count, "e").End(xlUp).Row)
Set c = .Find(cel, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Interior.ColorIndex = ci
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
ci = ci + 1
Next cel
End Sub