Retain rows with Max values - Delete other rows

[Raj]

Hi,

The following rows in a sheet contain region-wise sales of two
products:

Product Region Sales
Toyota North 50
Nissan South 42
Toyota South 30
Toyota West 60
Nissan North 32
Nissan East 35
Nissan West 25
Toyota East 37

I am looking for VBA code that will retain only the rows with the
maximum sales for a product and delete the other rows.

ie for the above input, the output should be:

Toyota West 60
Nissan South 42

Thanks in Advance for the help.
Raj

 

[Don Guillett]

One way
Sub deletenonmaxrows()
Application.ScreenUpdating = False
mc = 1
For i = Cells(Rows.Count, mc).End(xlUp).Row To 2 Step -1
maxval = Evaluate("MAX(IF((A2:A9=""" & Cells(i, mc) & """),C2:C9))")
If Cells(i, mc + 2) <> maxval Then Rows(i).Delete 'MsgBox i
Next i
Application.ScreenUpdating = True
End Sub

 

[Don Guillett]

Better

Sub deletenonmaxrows1()
Application.ScreenUpdating = False
mc = 1
Lr = Cells(Rows.Count, mc).End(xlUp).Row
For i = Lr To 2 Step -1
maxval = Evaluate("MAX(IF((A2:A" & Lr & "=""" & Cells(i, mc) & """),C2:C" &
Lr & "))")
If Cells(i, mc + 2) <> maxval Then Rows(i).Delete 'MsgBox i
Next i
Application.ScreenUpdating = True
End Sub