Nick,

Thanks for that. It works perfectly

Regards,

Steve w


"Nick H" wrote in message
...
Sorry Steve, just noticed that you mention there could be 'equal
maximums' which also need flagging.
Here's an improved version...

Public Sub FlagMaximums()
Dim c As Range
Dim rngGroups As Range
Dim arrFlags()
Dim TopRow As Long
Dim CurrentGroup
Dim MaxPct As Single
Dim arrRecent() As Long
Dim i As Long

Set rngGroups = Selection
TopRow = rngGroups(1).Row
MaxPct = 0

ReDim arrFlags(rngGroups.Rows.Count - 1)

For Each c In rngGroups
If Len(c.Value) 0 Then
arrFlags(c.Row - TopRow) = 0

If c.Value = CurrentGroup Then
If c.Offset(0, 1) MaxPct Then
For i = 0 To UBound(arrRecent)
arrFlags(arrRecent(i)) = 0
Next i

ReDim arrRecent(0)
arrRecent(0) = c.Row - TopRow

arrFlags(arrRecent(0)) = 1
MaxPct = c.Offset(0, 1)
ElseIf c.Offset(0, 1) = MaxPct Then
ReDim Preserve arrRecent(UBound(arrRecent) + 1)
arrRecent(UBound(arrRecent)) = c.Row - TopRow
arrFlags(arrRecent(UBound(arrRecent))) = 1
End If
Else
ReDim arrRecent(0)
arrRecent(0) = c.Row - TopRow

arrFlags(arrRecent(0)) = 1
MaxPct = c.Offset(0, 1)
CurrentGroup = c.Value
End If
End If
Next c

rngGroups.Offset(0, 2) = Application.WorksheetFunction.Transpose
(arrFlags)
End Sub


Br, Nick H