Hello All
The attached macro will only work on Sheet 1,is it possible to modify it to work on any worksheet.
Many thanks for help given.
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
Bookmarks