Highlight highest value in each row for various columns

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

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

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

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