Sub Test_Max()
Dim Cellules As Range
Set Cellules = Range("B4:B" & Range("B65536").End(xlUp).Row)
LaCel = Application.WorksheetFunction.Max(Cellules)
With ActiveSheet.Range("B:B")
Set Rng = .Find(What:=LaCel, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
.Select
End With
Set minCellules = Range("B" & Rng.Row & ":B" & Range("B65536").End(xlUp).Row)
LaCel2 = Application.WorksheetFunction.Min(minCellules)
' MsgBox LaCel2
With ActiveSheet.Range("B:B")
Set minrng = .Find(What:=LaCel2, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
.Select
End With
MsgBox minrng.Offset(0, 1).Value
End Sub