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("A[COLOR=red][B]2[/B][/COLOR]: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 SubPublic 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("A2: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
Set rng = .FindNext(rng)
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
