VBA to highlight Top N Values in Rows Based on Specific Range

[chingching831]

Hi there,

I would like to use VBA code to highlight the highest values (cell in yellow, font in bold and red) of each row based on B2:G21.
May I know how the below VBA can be revised in order to achieve the expected result shown below?

Sub Highlight_Max_Values_in_Rows()
    ActiveSheet.UsedRange
    Dim rA As Range, r, wf As WorksheetFunction
    Dim V As Variant, RWW As Range, rr As Range
    Set rA = Intersect(Range("A:A"), ActiveSheet.UsedRange)
    Set wf = Application.WorksheetFunction
    For Each r In rA
        Set RWW = Intersect(r.EntireRow, ActiveSheet.UsedRange)
        If wf.CountA(RWW) = 0 Then Exit Sub
        V = wf.Max(RWW)
        For Each rr In RWW
            If rr.Value = V Then
                rr.Interior.ColorIndex = 6
                rr.Font.Bold = True
                rr.Font.ColorIndex = 3
                GoTo getaway
            End If
        Next rr
getaway:
    Next r
End Sub

 

[MikeVol]

Hi @chingching831.
Try the following modified code:

Option Explicit

Sub Highlight_Max_Values_in_Rows()
    Dim r           As Variant

    With Range("B2:G22")
        .ClearFormats
        .Font.Bold = False
        .Font.ColorIndex = xlAutomatic
        .Interior.ColorIndex = xlNone
    End With

    Dim rA          As Range
    Set rA = Range("B2:B22")    ' Change to the range you need

    For Each r In rA

        Dim RWW     As Range
        Set RWW = Range("B" & r.Row & ":G" & r.Row)
        If Application.WorksheetFunction.CountA(RWW) = 0 Then Exit Sub

        Dim V       As Variant
        V = Application.WorksheetFunction.Max(RWW)

        Dim rr      As Range

        For Each rr In RWW

            If rr.Value = V Then
                rr.Interior.Color = RGB(255, 255, 0)
                rr.Font.Bold = True
                rr.Font.Color = RGB(255, 0, 0)
                Exit For
            End If

        Next rr

    Next r

    Set RWW = Nothing
    Set rA = Nothing
End Sub

Maybe this is what you want to get as a result, if I understood you correctly. Good luck.

 

[myall_blues]

Another option.

Sub Highlight_Max_Values_in_Rows()
    Dim numarea As Range
    Dim c As Long, i As Long, maxcol As Long
    Dim maxval As Double
    Set numarea = Range("B2:G21")
    For i = 1 To numarea.Rows.Count
        maxval = numarea(i, 1)
        maxcol = 1
        For c = 2 To numarea.Columns.Count
            If numarea(i, c) > maxval Then
                maxval = numarea(i, c)
                maxcol = c
            End If
        Next c
        With numarea(i, maxcol)
            .Interior.ColorIndex = 6
            .Font.Bold = True
            .Font.ColorIndex = 3
        End With
    Next i
End Sub

 

[footoo]

Another one :

Sub Highlight_Max_Values_in_Rows()
Dim rng As Range, cel$, r&
Set rng = Range([A1], ActiveSheet.UsedRange)
With rng
    .Font.ColorIndex = xlAutomatic
    .Font.Bold = False
    .Interior.ColorIndex = xlNone
End With
For r = 1 To rng.Rows.Count
    If WorksheetFunction.CountA(Rows(r)) = 0 Then GoTo n
    cel = ActiveSheet.Rows(r).Find(WorksheetFunction.Max(ActiveSheet.Rows(r))).Address
    With Range(cel)
        .Interior.ColorIndex = 6
        .Font.Bold = True
        .Font.ColorIndex = 3
    End With
n: Next r
End Sub

 

[chingching831]

Thanks much for all your help!! All of them work well.