Capturing Highest Historical Rank in a Continuously Updated Worksheet

[Mz309Lord]

I have a list of sites that are being ranked based on various factors that feed into the "score" equation, and I also want to be able to capture and save the highest rank each site has ever achieved (and the date of that high ranking).

This is currently captured in an Excel 365 sheet on Sharepoint where various people are able to make updates to factors feeding into the score equation as well as adding new sites to the list. Here's a basic view of the worksheet:

Site	Score	Date	Rank	Highest Historical Rank	Date of Highest Historical Rank
a	90	1/5/24	1	??	??
b	80	1/17/24	2
c	70	1/4/24	3
d	60	2/1/24	4
e	50	1/29/24	5

The "score" is an equation (which updates depending on the whatever the inspector finds on the given date). I have limited VBA skills, so was able to cut and paste someone else's code to get a new field called "previous rank," however, since I want to capture the all time highest rank a site has ever achieved, I'm drawing a blank as to how to maintain that high score. (Here's the tutorial I used to store the previous rank: How to remember or save previous cell value of a changed cell in Excel?)

 

[Coyotex3]

Will you only have 1 score per site?

I'm honestly unsure how to approach what you are trying to do .Let's say you have 90 in cell B2 and tomorrow you update that with 93. Will the 90 still appear on the sheet, or will only 93 appear? If it is the latter, I don't know that a formula would be able to retain historical information once the original data has been overwritten. Perhaps this can be done with VBA.

 

[Mz309Lord]

Here is what I'm considering might work, but I'm not quite sure how to code it:

Will you only have 1 score per site?

I'm honestly unsure how to approach what you are trying to do .Let's say you have 90 in cell B2 and tomorrow you update that with 93. Will the 90 still appear on the sheet, or will only 93 appear? If it is the latter, I don't know that a formula would be able to retain historical information once the original data has been overwritten. Perhaps this can be done with VBA.

Yes, that's correct. So far, I've found some VBA code to successfully store the previous score. But then I'm still blanking out on how to retain the highest all-time score without ending up with circular references. Here's my table so far:

A	B	C	D	E	F
Site	Score	Date	Previous value	Highest All Time Score	Previous High
A	90	2/12/24	87	=Max(B,D,F) NOTE: I'm hopeful this doesn't give me a circular reference error...	*need the VBA code to capture this that won't mess up the VBA code I already used to capture column D
B	80	2/12/24	56
C	70	2/12/24	54

Here is the VBA code I found posted somewhere else to give me column D:

Dim xRg As Range
'Updated by Extendoffice 20220803
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long
    Dim xCell As Range
    Dim xDCell As Range
    Dim xHeader As String
    Dim xCommText As String
    Dim X
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    xHeader = "Previous value :"
    X = xDic.Keys
    For I = 0 To UBound(xDic.Keys)
        Set xCell = Range(xDic.Keys(I))
        Set xDCell = Cells(xCell.Row, 4)
        
        xDCell.NumberFormatLocal = xCell.NumberFormatLocal
        xDCell.Value = xDic.Items(I)
        
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim I, J As Long
    Dim xRgArea As Range
    On Error GoTo Label1
    If Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    Set xDependRg = Target.Dependents
    If xDependRg Is Nothing Then GoTo Label1
    If Not xDependRg Is Nothing Then
        Set xDependRg = Intersect(xDependRg, Range("B:B"))
    End If
Label1:
    Set xRg = Intersect(Target, Range("B:B"))
    If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
        Set xChangeRg = Union(xRg, xDependRg)
    ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
        Set xChangeRg = xDependRg
    ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
        Set xChangeRg = xRg
    Else
        Application.EnableEvents = True
        Exit Sub
    End If
    xDic.RemoveAll
    For I = 1 To xChangeRg.Areas.Count
        Set xRgArea = xChangeRg.Areas(I)
        For J = 1 To xRgArea.Count
            xDic.Add xRgArea(J).Address, xRgArea(J).Text ' xRgArea(J).Formula
        Next
    Next
    Set xChangeRg = Nothing
    Set xRg = Nothing
    Set xDependRg = Nothing
    Application.EnableEvents = True
End Sub