VBA Code for Maximum Value

[erenkey]

I am looking for a VBA code that will look at a spreadsheet with Name in Column A and a Value in Column B, and pull back the maximum value for each name that is in the spreadsheet. each name can be in the spreadsheet up to 3 different times but I only want the maximum value pulled back.

Can anyone help me?

 

[MrKowz]

You should be able to do this with a pivot table. However, if you absolutely need it to be VBA, try the following code. This is untested (and my first time using the Scripting.Dictionary), but try the following. It will create the list of unique names in column D and their max values in Column E.

Public Sub MaxValue()
Dim i       As Long, _
    LR      As Long, _
    rng     As Range, _
    rng1    As String, _
    tmp     As Double, _
    dic     As Variant, _
    rowx    As Long
    
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
LR = Range("A" & Rows.Count).End(xlUp).Row
Set dic = CreateObject("Scripting.Dictionary")
rowx = 1
For i = 1 To LR - 1
    tmp = -999999
    Application.StatusBar = "Currently on row " & i & " of " & LR
    If Not dic.exists(Range("A" & i).Value) Then
        dic.Add Range("A" & i).Value
        With Range("A1:A" & LR)
            Set rng = .Find(Range("A" & i).Value, LookIn:=xlValues)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    If rng.Offset(0, 1).Value > tmp Then
                        tmp = rng.Offset(0, 1)
                    End If
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
        Range("D" & rowx).Value = Range("A" & i).Value
        Range("E" & rowx).Value = tmp
        rowx = rowx + 1
    End If
Next i
      
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With
End Sub

 

[erenkey]

I tried to run this code and got the following Error:

Compile Error:

Syntax Error

 

[MrKowz]

Strange, it compiles perfectly fine on my end.

Can you please provide some sample data and I will test it on my end?

 

[erenkey]

My employer will not allow me to download anything that will show my data. I simply have Name in Column A and a Numeric value in Column B.

Column A Column B
Chris 74
Greg 240
John 11
Greg 23
Chris 2161
Bob 150
Greg 195
Chris 68
Bob 221
John 25
John 259
Bob 5
Chris 13
Bob 178
John 123
Greg 122


I started over to make sure that I did it correctly. The data is in Sheet 1. I opened the VBA Editor. Right clicked on the top left window VBA Project and inserted a module. I copied your code and pasted into the module window that opened. I hit run and received a run time error '450': Wrong number of argumentsor invalid property assignment. I ran the debug and it highlighted the line

dic.Add Range("A" & i).Value

 

[MrKowz]

Thank you for the sample data.

It was an error on my end, slight issue with that Add statement. I tested the following code and it worked.

Public Sub MaxValue()
Dim i       As Long, _
    LR      As Long, _
    rng     As Range, _
    rng1    As String, _
    tmp     As Double, _
    dic     As Variant, _
    rowx    As Long
    
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
LR = Range("A" & Rows.Count).End(xlUp).Row
Set dic = CreateObject("Scripting.Dictionary")
rowx = 1
For i = 1 To LR - 1
    tmp = -999999
    Application.StatusBar = "Currently on row " & i & " of " & LR
    If Not dic.exists(Range("A" & i).Value) Then
        dic.Add Range("A" & i).Value[COLOR=red][B], 1
[/B][/COLOR]        With Range("A1:A" & LR)
            Set rng = .Find(Range("A" & i).Value, LookIn:=xlValues)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    If rng.Offset(0, 1).Value > tmp Then
                        tmp = rng.Offset(0, 1)
                    End If
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
        Range("D" & rowx).Value = Range("A" & i).Value
        Range("E" & rowx).Value = tmp
        rowx = rowx + 1
    End If
Next i
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With
End Sub

 

[erenkey]

When I try to run it I get a mismatch type error. If I take out the headers and run it it works. Where can I change the code to account for the headers in row 1?

If I wanted to change my data sheet to include last name in Column B causing the numeric values to shift to Column C, how would I make that change in the code?

 

[MrKowz]

Public Sub MaxValue()
Dim i       As Long, _
    LR      As Long, _
    rng     As Range, _
    rng1    As String, _
    tmp     As Double, _
    dic     As Variant, _
    rowx    As Long
    
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
LR = Range("A" & Rows.Count).End(xlUp).Row
Set dic = CreateObject("Scripting.Dictionary")
rowx = 1
For i = [COLOR=red][B]2[/B][/COLOR] To LR - 1
    tmp = -999999
    Application.StatusBar = "Currently on row " & i & " of " & LR
    If Not dic.exists(Range("A" & i).Value) Then
        dic.Add Range("A" & i).Value, 1
        With Range("A1:A" & LR)
            Set rng = .Find(Range("A" & i).Value, LookIn:=xlValues)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    If rng.Offset(0, 1).Value > tmp Then
                        tmp = rng.Offset(0, 1)
                    End If
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
        Range("D" & rowx).Value = Range("A" & i).Value
        Range("E" & rowx).Value = tmp
        rowx = rowx + 1
    End If
Next i
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With
End Sub

 

[erenkey]

Can you sort the results descending by value in the code?

 

[MrKowz]

Can you sort the results descending by value in the code?

Sure can, try:

Public Sub MaxValue()
Dim i       As Long, _
    LR      As Long, _
    rng     As Range, _
    rng1    As String, _
    tmp     As Double, _
    dic     As Variant, _
    rowx    As Long
    
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
LR = Range("A" & Rows.Count).End(xlUp).Row
Set dic = CreateObject("Scripting.Dictionary")
rowx = 1
For i = 2 To LR - 1
    tmp = -999999
    Application.StatusBar = "Currently on row " & i & " of " & LR
    If Not dic.exists(Range("A" & i).Value) Then
        dic.Add Range("A" & i).Value, 1
        With Range("A1:A" & LR)
            Set rng = .Find(Range("A" & i).Value, LookIn:=xlValues)
            If Not rng Is Nothing Then
                rng1 = rng.Address
                Do
                    If rng.Offset(0, 1).Value > tmp Then
                        tmp = rng.Offset(0, 1)
                    End If
                Loop While Not rng Is Nothing And rng.Address <> rng1
            End If
        End With
        Range("D" & rowx).Value = Range("A" & i).Value
        Range("E" & rowx).Value = tmp
        rowx = rowx + 1
    End If
Next i
Columns("D:E").Sort Key1:=Range("E1"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With
End Sub