Multiple maximums in column
Hi Steve,
Try this (beware of wrap-arou
nd)...
Assumptions:
- The three columns are consecutive
- The set of groups is selected and ordered
You could of course use a defined range name rather than 'Selection'.
Or, if you know the column and/or column header you could define the
group range at run-time.
Public Sub FlagMaximums()
Dim c As Range
Dim rngGroups As Range
Dim arrFlags()
Dim TopRow As Long
Dim CurrentGroup
Dim MaxPct As Single
Dim RecentMax As Long
Dim i As Long
Set rngGroups = Selection
TopRow = 0
MaxPct = 0
RecentMax = -1
ReDim arrFlags(rngGroups.Rows.Count - 1)
For Each c In rngGroups
If TopRow = 0 Then TopRow = c.Row
If Len(c.Value) 0 Then
arrFlags(c.Row - TopRow) = 0
If c.Value = CurrentGroup Then
If c.Offset(0, 1) MaxPct Then
arrFlags(RecentMax) = 0
RecentMax = c.Row - TopRow
arrFlags(RecentMax) = 1
MaxPct = c.Offset(0, 1)
End If
Else
RecentMax = c.Row - TopRow
arrFlags(RecentMax) = 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
|