Sub ColorMinMaxRates()

'Revised to color min and max in group's columns

Dim GroupName As String
Dim GroupRng As Range
Dim i As Long, j As Long
Dim MaxRate As Double
Dim MinRate As Double
Dim NextName As String
Dim R As Long
Dim Rng As Range
Dim RngEnd As Range
Dim StartRow As Long
Dim wks As Worksheet

Set wks = Worksheets("Sheet1")
Set Rng = wks.Range("A2:AP2")

Set RngEnd = wks.Cells(Rows.Count, Rng.Column).End(xlUp)
If RngEnd.Row < Rng.Row Then Exit Sub

Set Rng = Rng.Resize(RowSize:=RngEnd.Row - Rng.Row + 1)

Application.ScreenUpdating = False

StartRow = 1

For R = 1 To Rng.Rows.Count

GroupName = Rng.Item(R, 1) & Rng.Item(R, 4) & Rng.Item(R, 5)
NextName = Rng.Item(R + 1, 1) & Rng.Item(R + 1, 4) & Rng.Item(R + 1, 5)

If GroupName <> NextName Then
Set GroupRng = Rng.Item(StartRow, 6).Resize(R - StartRow + 1, 5)

For i = 11 To 21

MinRate = WorksheetFunction.Min(GroupRng.Columns(i))
MaxRate = WorksheetFunction.Max(GroupRng.Columns(i))
For j = 1 To GroupRng.Rows.Count
Select Case GroupRng.Item(j, i)
Case MinRate
GroupRng.Item(j, i).Font.Color = vbGreen
Case MaxRate
GroupRng.Item(j, i).Font.Color = vbRed
End Select
Next j
Next i

StartRow = R + 1
End If

Next R

Application.ScreenUpdating = True

End Sub