Solved: Colour format cells in each row with highest values

[Nick_London]

Hi,

I'm looking to automate a very time consuming task.

I have a range of data from B1 to CT2000, for each row in this range I'd like to format the top 3 cells with the highest values in say yellow.

So for example in row two, if the highest top three values occur in cells/columns D, Z, BC I went to format these cells in red (A2, Z2, BC2), then I want to do the same for the next row.

But what makes things a little complicated is there are about 100 random occuring rows in the range where there is no numerical data. But I do not want to delete these rows as they contain descriptive information about the data, So I need the macro to run only on rows where there is numerical data. If there is a numeric value in column B then that row will have numerical data in all the other columns, otherwise the row will either be blank or contain non numeric information.

I really hope someone can help me with this task.

Thanks,

Nick

[tstav]

Column CT is column 98. I have hard-coded it (97 items in the array), but it can also be found through code (see below).

Check for numeric cell in column B.
Store all cell values of each row to an array.
Find the max value and then find its location in the array.
Color the relevant cell.
Change this array item's value to zero.
Repeat two more times.

Regards, tstav
[vba]Sub ColorCellsOf3HigherValues()
Dim i As Long, k As Long, lastRow As Long, maxCol As Long, maxLoc As Long
Dim arr(1 To 97) As Single, maxNum As Single
maxCol = Range("CT1").Column
lastRow = Range("B" & Rows.count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 1 To lastRow
If Cells(i, "B").Value <> "" And IsNumeric(Cells(i, "B").Value) Then
For k = 2 To maxCol
arr(k - 1) = CSng(Cells(i, k).Value)
Next
maxNum = WorksheetFunction.Max(arr)
maxLoc = WorksheetFunction.Match(maxNum, arr, 0)
Cells(i, maxLoc + 1).Interior.ColorIndex = 6
arr(maxLoc) = 0

maxNum = WorksheetFunction.Max(arr)
maxLoc = WorksheetFunction.Match(maxNum, arr, 0)
Cells(i, maxLoc + 1).Interior.ColorIndex = 6
arr(maxLoc) = 0

maxNum = WorksheetFunction.Max(arr)
maxLoc = WorksheetFunction.Match(maxNum, arr, 0)
Cells(i, maxLoc + 1).Interior.ColorIndex = 6
End If
Next
Application.ScreenUpdating = True
End Sub[/vba]

Edit: Changed colorindex to 6 (yellow)
Edit: Added the check for non-blank cell in column B

[lenze]

Can't you just use Conditional Formatting?
=OR(B1=LARGE($B1:$CT1,1),B1=LARGE($B1:$CT1,2),B1=LARGE($B1:$CT1,3)

Should ignore rows with no numerical data.

lenze

[tstav]

IMOSTCERTAINLYDON'TLIKETOCOUNTPARENTHESESINLONGSTRINGSTOMAKEAFORMULAWORK.



That's my usual way of joking, when I want to say that, sure, formulas are great, but some of them I find kind of cryptic and unfriendly (as far as reading them is concerned). This does not concern your formula, though.

That's why I tend to avoid them. But that's just me of course...

By the way , you ARE missing a closing parenthesis .

Edit: Hadn't thought of Large function. Good idea lenze, thank you.

[lenze]

By the way , you ARE missing a closing parenthesis .

Yeap
=OR(B1=LARGE($B1:$CT1,1),B1=LARGE($B1:$CT1,2),B1=LARGE($B1:$CT1,3))

lenze

[tstav]

And what happens if there are more than one same cell values in a row?
Rephrasing: If in a row the max value is 10, and we have two cells with the value of 10, or three cells, or four?
We will have to find all these cells and color them all. Then we should look for the next high value and so on.

So, I revised the code to color all cells with the same value. That is if the 3 max values are e.g. 30, 20 and 10 the code will color all instances of 30, 20 and 10.

PS. The code will not work correctly in case zero is one of the three high values, but I guess this should be highly unprobable.

[vba]Sub ColorCellsOf3HigherValues1()
Dim i As Long, k As Long, lastRow As Long, maxCol As Long, maxLoc As Long
Dim arr(1 To 97) As Single, maxNum As Single
Dim counter As Integer

maxCol = Range("CT1").Column
lastRow = Range("B" & Rows.count).End(xlUp).Row

Application.ScreenUpdating = False
On Error Resume Next

'Check each row
For i = 1 To lastRow
If Cells(i, "B").Value <> "" And IsNumeric(Cells(i, "B").Value) Then

'Assign cells' values to array
For k = 2 To maxCol
arr(k - 1) = CSng(Cells(i, k).Value)
Next

'Find 3 higher values
For counter = 1 To 3
'Get the max
maxNum = WorksheetFunction.Max(arr)
Do
'Get location of max
maxLoc = WorksheetFunction.Match(maxNum, arr, 0)
If Err Then Exit Do
'Color the cell value
Cells(i, maxLoc + 1).Interior.ColorIndex = 6
'Zero the array item
arr(maxLoc) = 0
Loop
Err.Clear
Next 'counter

End If
Next 'i
Application.ScreenUpdating = True
End Sub[/vba]

[Bob Phillips]

Yeap
=OR(B1=LARGE($B1:$CT1,1),B1=LARGE($B1:$CT1,2),B1=LARGE($B1:$CT1,3))

lenze

=OR(B1=LARGE($B1:$CT1,ROW(INDIRECT("1:3"))))

You could even stick the upper limit in a cell, say A1, and use this

=OR(B1=LARGE($B1:$CT1,ROW(INDIRECT("1:"&$A$1))))