I am a supporter of
St. Joseph's hospice.
 If you find this site useful or if it helped you, consider a small donation to
St. Joseph's, please.

Information on
St. Joseph's

JustGiving - Sponsor me now!

 

sbCellWatermarks

If you need to keep track of extreme values of a cell you can use the VBA code as shown below. The code works for numbers as well as for text.

sbCellWatermarks_01_Screen

If you are interested in downloading a 20 KB Excel 2010 © sample file which contains the code shown here, go to my Download page, please.

Option Explicit

Sub auto_open()
    Application.EnableEvents = True
End Sub

Sub sbCellWatermarks(rCell As Range, rOutput As Range)
'Keep track of extreme values of a cell calculation.
'Call this sub from a worksheet's calculation event like
'Private Sub Worksheet_Change(ByVal Target As Range)
'    Call sbCellWatermarks(Range("watermark_cell"), _
'            Range("watermark_output"))
'End Sub
'If named range watermark_cell is set to B2 and watermark_output to
'B5:E6 a calculation example could be like:
'    Result  DateTime           Formula       Input Parameters
'Max    0    13/12/2008 12:41   =-((B1-3)^2)  3
'Min   -4    13/12/2008 12:46   =-((B1-3)^2)  5
'Reverse("moc.LiborPlus.www") V0.21 PB 24-Jul-2011

Dim i As Long, k As Long, p As Long, v As Variant

'Check input parameters thoroughly because we will switch off events
If Not TypeOf rCell Is Range Or Not TypeOf rOutput Is Range Then
    Call MsgBox("Input cell or output area are not of type RANGE!", _
            vbOKOnly, "Error")
    Exit Sub
End If
If rCell.Count <> 1 Then
    Call MsgBox("Input range should contain only 1 cell!", _
            vbOKOnly, "Error")
    Exit Sub
End If
If rCell.HasFormula Then p = rCell.DirectPrecedents.Count
If rOutput.Rows.Count < 2 Or rOutput.Columns.Count < 3 + p Then
    Call MsgBox("Output range should contain at least 2 rows and " & _
            3 + p & " columns!", vbOKOnly, "Error")
    Exit Sub
End If

Application.EnableEvents = False

k = Application.Calculation
Application.Calculation = xlCalculationManual
rCell.Calculate

If rCell.FormulaLocal <> rOutput(1, 3) Then
    'If formula changed reset statistics
    rOutput.ClearContents
    rOutput(1, 1) = rCell
    rOutput(2, 1) = rCell
    rOutput(1, 2) = Now
    rOutput(2, 2) = rOutput(1, 2)
    rOutput(1, 3) = "'" & rCell.FormulaLocal
    rOutput(2, 3) = "'" & rCell.FormulaLocal
    If rCell.HasFormula Then
        i = 4
        For Each v In rCell.DirectPrecedents
            rOutput(1, i) = v
            rOutput(2, i) = v
            i = i + 1
        Next v
    End If
ElseIf rCell > rOutput(1, 1) Then
    rOutput(1, 1) = rCell
    rOutput(1, 2) = Now
    If rCell.HasFormula Then
        i = 4
        For Each v In rCell.DirectPrecedents
            rOutput(1, i) = v
            i = i + 1
        Next v
    End If
ElseIf rCell < rOutput(2, 1) Then
    rOutput(2, 1) = rCell
    rOutput(2, 2) = Now
    If rCell.HasFormula Then
        i = 4
        For Each v In rCell.DirectPrecedents
            rOutput(2, i) = v
            i = i + 1
        Next v
    End If
End If

Application.Calculation = k
Application.EnableEvents = True

End Sub

Sulprobil   Get it done   Contact   Disclaimer   Impressum   Download