Logo 
Search:

MS Office Answers

Ask Question   UnAnswered
Home » Forum » MS Office       RSS Feeds
  Question Asked By: Muaz Bashara   on Jan 26 In MS Office Category.

  
Question Answered By: Zivah Levi   on Jan 26

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

Share: 

 

This Question has 2 more answer(s). View Complete Question Thread

 
Didn't find what you were looking for? Find more on find min and match Or get search suggestion and latest updates.


Tagged: