Hi,

I have one column with numbers, can be repeated or missing - e.g. 1,1,1,1 -
2 - 3,3,3,3,3 - 5,5 - 6 - 8,8,8 etc. highest number is 10, but list can be
up to 250 rows. A second column has percentages for each entry in the first
column, can be repeated within a number group - e.g. 65,68,65,54 - 48 -
76,49,76,54,76 - 68,69 - 90 - 42,43,44 (percentages can actually be to 2
decimal places, simplified for example). Into a third column I want to
insert a number, 1 for the maximum or equal maximum within a number group
and 0 for all others. Results for the example would be as follows: 0,1,0,0 -
1 - 1,0,1,0,1 - 0,1 - 1 - 0,0,1

would be grateful for any help with a Vba solution for this

Steve W

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

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

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