That's an additional requirement you didn't mention before. Try this modified
code:
Sub AAAA()
ActiveSheet.Range("M5").Value = FindValue("L", "A", 5)
End Sub
Public Function FindValue(ColToSearch As String, ColToReturn As String,
FirstRow As Long) As Double
'Finds the smallest value in ColToSearch. Then searches ColToSearch for the
value which is
'closest to half that value and has an index (ColToReturn value) which is
greater than the index for
'the min value. When the closest value in ColToSearch has been identified,
returns the value in
'ColToReturn from that row.
Dim msg1 As String, MinVal As Double, MinIndex As Double, HalfMin As Double,
Rng As Range
Dim ClosestVal As Double, ClosestRow As Long, Diff As Double, LastRow As
Long
On Error GoTo FVerr1
'Find the last row with data in ColToSearch.
LastRow& = FindLastRow(ColToSearch$)
'Set the Rng object variable to the data range in ColToSearch. Must use a Range
object variable when
'using the Min function from VBA.
Set Rng = ActiveSheet.Range(ColToSearch$ & FirstRow & ":" & ColToSearch$ &
LastRow&)
'Find the smallest value. Store its index. Divide smallest value by 2 and store
as MinVal#.
MinVal# = Application.WorksheetFunction.Min(Rng)
MinIndex# = Range(ColToReturn$ &
CLng(Application.WorksheetFunction.Match(MinVal#, Rng, 0) + FirstRow& -
1)).Value
HalfMin# = MinVal# / 2
ClosestVal# = 0
'Walk down through the cells in ColToSearch and find the closest value to
HalfMin#.
Application.ScreenUpdating = False
Range(ColToSearch$ & FirstRow).Activate
Do While ActiveCell.Row <= LastRow&
'Only interested in this cell if its index (ColToReturn value) is greater than
MinIndex#.
If Range(ColToReturn$ & ActiveCell.Row).Value > MinIndex# Then
'Measure how far this cell's value is from HalfMin#
Diff# = Abs(ActiveCell.Value - HalfMin#)
'If this cell's value is closer to HalfMin# than the current ClosestVal#, make
this cell
'the new ClosestVal and store its row number.
If (Diff# < Abs(HalfMin# - ClosestVal#)) Then
ClosestVal# = ActiveCell.Value
ClosestRow& = ActiveCell.Row
End If
End If
ActiveCell.Offset(1, 0).Activate
Loop
'Return the value in ColToReturn from ClosestRow&.
FindValue# = Range(ColToReturn$ & ClosestRow&).Value
Cleanup1:
Application.ScreenUpdating = True
Set Rng = Nothing
Exit Function
FVerr1:
If Err.Number <> 0 Then
msg1$ = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg1$, , "FindValue error", Err.HelpFile, Err.HelpContext
End If
GoTo Cleanup1
End Function
Public Function FindLastRow(WhichCol As String) As Long
'Returns the last row in a column with something in it. Returns zero if the
'entire Column Is Empty
Dim LastRow As Long
LastRow& = 65536
If IsEmpty(Cells(LastRow&, WhichCol$)) Then
LastRow& = Cells(LastRow, WhichCol$).End(xlUp).Row
If LastRow& = 1 And IsEmpty(Cells(LastRow&, WhichCol$)) Then LastRow& =
0
End If
FindLastRow& = LastRow&
End Function