Highlight highest value in each row for various columns - excel

Question

I want to highlight cells with the largest value in each row but only using columns F, I, L, O and R.
Sub Highlights()
Dim ws As Worksheet
Dim ColorRng As Range
Dim ColorCell As Range
Set ws = Worksheets("Sheet2")
Set ColorRng = ws.Range("F7,I7,L7,O7,R7")
'highlight the cell that contains the highest and lowest number
For Each ColorCell In ColorRng
If ColorCell.Value = Application.WorksheetFunction.Max(ColorRng) Then
ColorCell.Interior.Color = RGB(0, 180, 40)
ElseIf ColorCell.Value = Application.WorksheetFunction.Min(ColorRng) Then
ColorCell.Interior.Color = RGB(255, 0, 0)
End If
Next
End Sub
It works for the first row (that being row 7), but it doesn't continue to the next row. I realize this is because of my ColorRng range.
How do I allow the range to include more?

Answer 1

Please try this code.
Sub SetHighlights()
Dim ColorRng As Range
Dim ColorCell As Range ' loop object
Dim Mini As Variant
Dim Maxi As Variant
Dim R As Long ' loop counter: rows
Dim C As Long ' loop counter: columns
Dim n As Integer ' result counter
'highlight the cell that contains the highest and lowest number
Application.ScreenUpdating = False
With Worksheets("Sheet2")
For R = 2 To .Cells(.Rows.Count, "F").End(xlUp).Row
Set ColorRng = Union(.Cells(R, "F"), .Cells(R, "I"), _
.Cells(R, "L"), .Cells(R, "R"))
Mini = Application.Min(ColorRng)
Maxi = Application.Max(ColorRng)
For Each ColorCell In ColorRng
With ColorCell
If .Value = Maxi Then
.Interior.Color = RGB(0, 180, 40)
n = n + 1
ElseIf .Value = Mini Then
.Interior.Color = RGB(255, 0, 0)
n = n + 1
End If
End With
If n = 2 Then Exit For
Next ColorCell
Next R
End With
Application.ScreenUpdating = True
End Sub
Observe that the Min and Max functions are run only once per row instead of for each cell as your original code had it. Turning off ScreenUpdating further enhances the speed with which the procedure can complete the job

Answer 2

Give a try on below sub. As you need to highlight in every row, so you have to iterate every row to compare.
Sub Highlights()
Dim ws As Worksheet
Dim ColorRng As Range
Dim ColorCell As Range
Dim lRow As Long
Set ws = Worksheets("Sheet2")
lRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
With ws
For i = 7 To lRow
Set ColorRng = Union(.Range("F" & i), .Range("I" & i), .Range("L" & i), .Range("O" & i), .Range("R" & i))
For Each ColorCell In ColorRng
If ColorCell.Value = Application.Max(ColorRng) Then
ColorCell.Interior.Color = RGB(0, 180, 40)
ElseIf ColorCell.Value = Application.Min(ColorRng) Then
ColorCell.Interior.Color = RGB(255, 0, 0)
End If
Next ColorCell
Set ColorRng = Nothing
Next i
End With
End Sub

Answer 3

Highlight Mins and Maxes
If error values, it will fail.
If no numeric value, then no color.
If max = min, then max color.
Adjust the values in the constants section.
The Code
Option Explicit
Sub highlightMinMax()
Const wsName As String = "Sheet2"
Const FirstRow As Long = 7
Const LastRowColumn As String = "F"
Const ColsList As String = "F,I,L,O,R"
Dim ColorMin As Long: ColorMin = RGB(255, 0, 0) ' 255
Dim ColorMax As Long: ColorMax = RGB(0, 180, 40) ' 2667520
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim rgCols As Range
Dim LastRow As Long
Dim i As Long
Set rgCols = ws.Columns(LastRowColumn)
LastRow = ws.Cells(ws.Rows.Count, LastRowColumn).End(xlUp).Row
If LastRow < FirstRow Then Exit Sub
Dim Cols() As String: Cols = Split(ColsList, ",")
For i = 0 To UBound(Cols)
Set rgCols = getCombinedRangeBasic(rgCols, ws.Columns(Cols(i)))
Next i
Erase Cols
Dim rgColor As Range
Dim cel As Range
Dim rgMin As Range
Dim rgMax As Range
Dim cMin As Double
Dim cMax As Double
For i = FirstRow To LastRow
Set rgColor = Intersect(rgCols, ws.Rows(i))
cMax = Application.Max(rgColor)
cMin = Application.Min(rgColor)
For Each cel In rgColor
If cel.Value = cMax Then
Set rgMax = getCombinedRangeBasic(rgMax, cel)
ElseIf cel.Value = cMin Then
Set rgMin = getCombinedRangeBasic(rgMin, cel)
End If
Next
Next i
If Not rgMin Is Nothing Then
rgMin.Interior.Color = ColorMin
End If
If Not rgMax Is Nothing Then
rgMax.Interior.Color = ColorMax
End If
End Sub
Function getCombinedRangeBasic( _
ByVal BuiltRange As Range, _
ByVal AddRange As Range)
If BuiltRange Is Nothing Then
Set getCombinedRangeBasic = AddRange
Else
Set getCombinedRangeBasic = Union(BuiltRange, AddRange)
End If
End Function

Answer 4

This proposed solution uses FormatConditions
FormatConditions will keep the Mins & Maxs updated when ever the values get changed.
Only need to rerun the procedure when the range changes.
However, FormatConditions are Volatile therefore need to evaluate the size of your data.
…
Sub FormatConditions_MinMax_NonContiguousRow()
Const kIni As Byte = 7
Dim Rng As Range, rRow As Range, lRow As Long
With ThisWorkbook.Sheets("Sheet2") 'Change as required
Rem Disable AutoFilter
If Not (.AutoFilter Is Nothing) Then .AutoFilter.Range.AutoFilter
Rem Set & Validate Last Row
lRow = .Columns("F").Cells(.Rows.Count).End(xlUp).Row
If lRow <= kIni Then Exit Sub
Rem Set Data Range
Set Rng = .Range("F" & kIni & ":R" & lRow)
End With
With Rng
Rem Delete prior FormatConditions
.FormatConditions.Delete
Rem Add FormatConditions by Row
For Each rRow In .Rows
With rRow
Rem Add FormatConditions Max
With .FormatConditions.AddTop10
.SetFirstPriority
.TopBottom = xlTop10Top
.Rank = 1
.Percent = False
.Interior.Color = RGB(255, 0, 0)
.StopIfTrue = True
End With
Rem FormatConditions Min
With .FormatConditions.AddTop10
.SetFirstPriority
.TopBottom = xlTop10Bottom
.Rank = 1
.Percent = False
.Interior.Color = RGB(0, 180, 40)
.StopIfTrue = True
End With
End With: Next
Rem Remove FormatConditions from Other Columns
Application.Intersect(.Cells, Range("G:H,J:K,M:N,P:Q")).FormatConditions.Delete
.Calculate
End With
End Sub