Need Help Improving/increase Speed of ChangeTracking Macro

Marciz

Warning: the attached file is provided as a proof of concept and will record hundreds of rows of data once opened. Users should be sure to click the "Stop" button ot the top of the Tdatas worksheet after a short while (since it triggers OnTime events which may repeat aftyer the file is closed).

In the revised, attached file I've written a new macro (in Module 2) which compares new values (with old) in arrays and writes any changes to an array. This is much faster than writing to worksheets (even with ScreenUpdating off).

On my old PC, the new macro takes about 0.3 seconds to run including setting the colour fill in the Previous Values area (AB6:AY155 of the Tdatas worksheet ) c.f. the new, current values (B6:Y155). 

The new file leaves me with random numbers in the current data rows5, 9 (to show a quirk- see below*) and 155, to limit the data recorded each second. For those rows, the fills for Previous Data will be either red or green but unchanged values will have a clear fill. You can put the formula =RAND() -in cells B3:Y155 but be warned that the Tracker sheet will fill quickly.

The Tracker sheet now shows how any changed value has moved (increased or decreased since last seen) and records a X/Y ref of your column and row headers (in addition to cell address) e.g. TA1 / 150. These can be ambiguous since you have column headings 1 to 6 then 6 to 1.

The commented code is below (note the additions in bold outside the macro, the second line to made the first index of arrays be numbered 1 rather than 0 as default):

Option Base 1
Option Explicit

Sub CompareToPrev()

Dim PrevArr As Variant, CurrArr As Variant, ChngArr As Variant
Dim m As Long, n As Long, r As Long, RecTime As String
Dim NxtRw As Long

Application.ScreenUpdating = False

'set Change counter and date/time for change records
r = 1
RecTime = Now

With Worksheets("TDatas")
    ' put current and last values in into arrays
    CurrArr = .Range("B6:Y155").Value
    PrevArr = .Range("AB6:AY155").Value
    ' clear Changes array (don't Preserve values)
    ReDim ChngArr(1 To UBound(CurrArr, 1) * UBound(CurrArr, 2), 1 To 5)
    ' loop through array, comparing values
    For m = LBound(CurrArr, 1) To UBound(CurrArr, 1)
        For n = LBound(CurrArr, 2) To UBound(CurrArr, 2)
            ' If cell differs from last time...
            If CurrArr(m, n) <> PrevArr(m, n) Then
                '...record values in array
                ChngArr(r, 1) = RecTime
                ChngArr(r, 2) = .Cells(m, n).Offset(5, 1).Address
                ChngArr(r, 3) = "'" & .Cells(5, n).Offset(0, 1).Value & " / " & .Cells(m, 1).Offset(5, 0).Value
                ChngArr(r, 4) = CurrArr(m, n)
                ChngArr(r, 5) = "Increased"
                If CurrArr(m, n) < PrevArr(m, n) Then
                    ChngArr(r, 5) = "Increased"
                    Else
                    ChngArr(r, 5) = "Decreased"
                End If
                r = r + 1
            End If
            ' Optional colour cells
            Select Case CurrArr(m, n)
                Case Is > PrevArr(m, n)
                    .Cells(m, n).Offset(5, 27).Interior.ColorIndex = 4 'green
                Case Is < PrevArr(m, n)
                    .Cells(m, n).Offset(5, 27).Interior.ColorIndex = 3 'red
                Case Else
                    .Cells(m, n).Offset(5, 27).Interior.ColorIndex = 2 ' white
            End Select
        Next n
    Next m
    
    'write current values to previous range
    .Range("AB6:AY155").Value = CurrArr

End With

'write these changes to Tracker
With Worksheets("Tracker")
    'get next unused row of column A
    NxtRw = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    'check max rows won't be exceeed
    If (NxtRw + UBound(ChngArr, 1) - 1) >= 1048576 Then
        MsgBox "Unable to paste records (would exceeed maximum rows). Stopping track changes"
        Exit Sub
    End If
    'write these new changes to Tracker
    .Range(.Cells(NxtRw, 1), .Cells(NxtRw + UBound(ChngArr, 1) - 1, 5)).Value = ChngArr
End With

Application.ScreenUpdating = True

' schedule next check
ScheduleTrackingOn

End Sub

I've also made these changes to your macros (so the start and stop buttons on TDatas work) and commented out your macro largely:

Dim TimeToRun
Sub auto_open()
'Application.ScreenUpdating = False

    Call ScheduleTrackingOn


End Sub
Sub ScheduleTrackingOn()
'Application.ScreenUpdating = False
    TimeToRun = Now + TimeValue("00:00:01")
    Application.OnTime TimeToRun, "CompareToPrev"
'Application.ScreenUpdating = True
End Sub

Sub auto_close()

    On Error Resume Next
    Application.OnTime TimeToRun, "CompareToPrev", , False

End Sub

Tdatas has a new button called "Reset Tracker sheet", behind which is this code:

Sub ResetTracker()

Dim NxtRw As Long

With Worksheets("Tracker")
    'get next unused row of column A
    NxtRw = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    'delete data
    .Range(.Cells(3, 1), .Cells(NxtRw, 1)).EntireRow.Delete
End With

End Sub

I leave you to reformat column A if needed (I wanted to see seconds).

* Note however that there's quirk in this file. Actual row 9 (only) doesn't work properly (apart from the first value) since the code sees the offset cell address as $Z$9 (and records that for X refs) and doesn't apply the Optional colour cells code correctly. For example, the record in the Tracker might read:

'07/Jul/2022 09:27:10    $Z$9    TA1 / 4      0.324665203 Increased

whereas the address should read $N$9. I just can't work out why this is and will ask a question in the Forum (and hope that Don or others can fathom it!) 

Hope this makes sense and works well for you.