Finding and Formatting the 5 highest values in a range?

[Lance Hoffmeyer]

Hey all,


I am trying to figure out a way to format a set of number so that the
number with the max value has a cell color of red, the next max value
has a cell color of yellow, the 3rd max value has a cell color of blue,
the 4th max value has a cell color of green, and the 5th max value has
a cell color of grey. If this is confusing replace the "max value" with
"top scoring". There will not be any ties.


For example

02
23 (yellow)
05
27 (red)
08
19 (blue)
01
10 (grey)
00
14 (green)
06


Has anyone done something similar to this?

Lance

 

[Jake Marx]

Hi Lance,

Something like this may work for you:

Sub ColorFinishers()
Dim rng As Range
Dim nPlace As Integer

Selection.Interior.ColorIndex = xlColorIndexNone

For Each rng In Selection
For nPlace = 1 To 5
If Application.WorksheetFunction.Large(Selection, nPlace) =
rng.Value Then
'/ color appropriately
Select Case nPlace
Case 1
rng.Interior.Color = vbRed
Case 2
rng.Interior.Color = vbYellow
Case 3
rng.Interior.Color = vbBlue
Case 4
rng.Interior.Color = vbGreen
Case 5
rng.Interior.Color = vbBlack
End Select
End If
Next nPlace
Next rng
End Sub

--
Regards,

Jake Marx
www.longhead.com


[please keep replies in the newsgroup - email address unmonitored]

 

[Bob Phillips]

Sub Test()
Dim iLastRow As Long
Dim i As Long

iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To iLastRow
Select Case True
Case Cells(i, "A").Value = Application.Large(Range("A:A"), 1)
Cells(i, "A").Interior.ColorIndex = 3
Case Cells(i, "A").Value = Application.Large(Range("A:A"), 2)
Cells(i, "A").Interior.ColorIndex = 6
Case Cells(i, "A").Value = Application.Large(Range("A:A"), 3)
Cells(i, "A").Interior.ColorIndex = 5
Case Cells(i, "A").Value = Application.Large(Range("A:A"), 4)
Cells(i, "A").Interior.ColorIndex = 10
Case Cells(i, "A").Value = Application.Large(Range("A:A"), 5)
Cells(i, "A").Interior.ColorIndex = 16
End Select
Next i

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[JakeyC]

Whilst these replies have flooded in I thought I might turn my novice
hand to the problem and came up with the following, much messier
solution for what it's worth...

It assumes that you have 20 numbers in cells A1:A20 on a sheet called
"Sheet1".

Option Explicit

Private Sub CommandButton1_Click()
Dim i As Integer
Dim theRange As Range
i = 1
Set theRange = Sheets("Sheet1").Range("A1:A20")
'Takes any existing colour formats away
theRange.Select
Selection.Interior.ColorIndex = xlNone

With Application.WorksheetFunction

'loop to check each number in the range with the RANK function and
colour accordingly

While i < 20
If .Rank(Cells(i, 1).Value, theRange, 0) = 1 Then
Cells(i, 1).Interior.ColorIndex = 3
End If

If .Rank(Cells(i, 1).Value, theRange, 0) = 2 Then
Cells(i, 1).Interior.ColorIndex = 6
End If

If .Rank(Cells(i, 1).Value, theRange, 0) = 3 Then
Cells(i, 1).Interior.ColorIndex = 5
End If

If .Rank(Cells(i, 1).Value, theRange, 0) = 4 Then
Cells(i, 1).Interior.ColorIndex = 16
End If

If .Rank(Cells(i, 1).Value, theRange, 0) = 5 Then
Cells(i, 1).Interior.ColorIndex = 10
End If

i = i + 1
Wend
End With

End Sub