Sulprobil
Search…
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.
Please read my Disclaimer.
1
Sub auto_open()
2
Application.EnableEvents = True
3
End Sub
4
5
Sub sbCellWatermarks(rCell As Range, rOutput As Range)
6
'Keep track of extreme values of a cell calculation.
7
'Call this sub from a worksheet's calculation event like
8
'Private Sub Worksheet_Change(ByVal Target As Range)
9
' Call sbCellWatermarks(Range("watermark_cell"), _
10
' Range("watermark_output"))
11
'End Sub
12
'If named range watermark_cell is set to B2 and watermark_output to
13
'B5:E6 a calculation example could be like:
14
' Result DateTime Formula Input Parameters
15
'Max 0 13/12/2008 12:41 =-((B1-3)^2) 3
16
'Min -4 13/12/2008 12:46 =-((B1-3)^2) 5
17
'Reverse("moc.LiborPlus.www") V0.21 PB 24-Jul-2011
18
19
Dim i As Long, k As Long, p As Long, v As Variant
20
21
'Check input parameters thoroughly because we will switch off events
22
If Not TypeOf rCell Is Range Or Not TypeOf rOutput Is Range Then
23
Call MsgBox("Input cell or output area are not of type RANGE!", _
24
vbOKOnly, "Error")
25
Exit Sub
26
End If
27
If rCell.Count <> 1 Then
28
Call MsgBox("Input range should contain only 1 cell!", _
29
vbOKOnly, "Error")
30
Exit Sub
31
End If
32
If rCell.HasFormula Then p = rCell.DirectPrecedents.Count
33
If rOutput.Rows.Count < 2 Or rOutput.Columns.Count < 3 + p Then
34
Call MsgBox("Output range should contain at least 2 rows and " & _
35
3 + p & " columns!", vbOKOnly, "Error")
36
Exit Sub
37
End If
38
39
Application.EnableEvents = False
40
41
k = Application.Calculation
42
Application.Calculation = xlCalculationManual
43
rCell.Calculate
44
45
If rCell.FormulaLocal <> rOutput(1, 3) Then
46
'If formula changed reset statistics
47
rOutput.ClearContents
48
rOutput(1, 1) = rCell
49
rOutput(2, 1) = rCell
50
rOutput(1, 2) = Now
51
rOutput(2, 2) = rOutput(1, 2)
52
rOutput(1, 3) = "'" & rCell.FormulaLocal
53
rOutput(2, 3) = "'" & rCell.FormulaLocal
54
If rCell.HasFormula Then
55
i = 4
56
For Each v In rCell.DirectPrecedents
57
rOutput(1, i) = v
58
rOutput(2, i) = v
59
i = i + 1
60
Next v
61
End If
62
ElseIf rCell > rOutput(1, 1) Then
63
rOutput(1, 1) = rCell
64
rOutput(1, 2) = Now
65
If rCell.HasFormula Then
66
i = 4
67
For Each v In rCell.DirectPrecedents
68
rOutput(1, i) = v
69
i = i + 1
70
Next v
71
End If
72
ElseIf rCell < rOutput(2, 1) Then
73
rOutput(2, 1) = rCell
74
rOutput(2, 2) = Now
75
If rCell.HasFormula Then
76
i = 4
77
For Each v In rCell.DirectPrecedents
78
rOutput(2, i) = v
79
i = i + 1
80
Next v
81
End If
82
End If
83
84
Application.Calculation = k
85
Application.EnableEvents = True
86
87
End Sub
Copied!
sbCellWatermarks.xlsm
17KB
Binary
sbCellWatermarks.xlsm
Last modified 1yr ago
Copy link