Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

Need Help Improving/increase Speed of ChangeTracking Macro

0

Here in my xlsm file I'm finding that when I run my macro, it(macro) take too long to fill up just 3600 cells. If anyone can help improve and increase the execution speed of my macro I'll be happy beyond the borders and boundaries. Thanks in advance(All vba code are available in file itself)

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, "TrackingOn"
Application.ScreenUpdating = True
End Sub
Sub TrackingOn()
Application.ScreenUpdating = False
Dim k As Integer
For k = 6 To 155
    If Cells(k, 2).Value <> Cells(k, 28).Value Then
    Cells(k, 28).Value = Cells(k, 2).Value
    Else
    End If
    Next   
Dim l As Integer
For l = 6 To 155
    If Cells(l, 3).Value <> Cells(l, 29).Value Then
    Cells(l, 29).Value = Cells(l, 3).Value
    Else
    End If
    Next
Dim m As Integer
For m = 6 To 155
    If Cells(m, 4).Value <> Cells(m, 30).Value Then
    Cells(m, 30).Value = Cells(m, 4).Value
    Else
    End If
    Next
Dim n As Integer
For n = 6 To 155
    If Cells(n, 5).Value <> Cells(n, 31).Value Then
    Cells(n, 31).Value = Cells(n, 5).Value
    Else
    End If
    Next
Dim o As Integer
For o = 6 To 155
    If Cells(o, 6).Value <> Cells(o, 32).Value Then
    Cells(o, 32).Value = Cells(o, 6).Value
    Else
    End If
    Next
Dim p As Long
For p = 6 To 155
    If Cells(p, 7).Value <> Cells(p, 33).Value Then
    Cells(p, 33).Value = Cells(p, 7).Value
    Else
    End If
    Next
Dim q As Integer
For q = 6 To 155
    If Cells(q, 8).Value <> Cells(q, 34).Value Then
    Cells(q, 34).Value = Cells(q, 8).Value
    Else
    End If
    Next
Dim r As Integer
For r = 6 To 155
    If Cells(r, 9).Value <> Cells(r, 35).Value Then
    Cells(r, 35).Value = Cells(r, 9).Value
    Else
    End If
    Next
Dim s As Integer
For s = 6 To 155
    If Cells(s, 10).Value <> Cells(s, 36).Value Then
    Cells(s, 36).Value = Cells(s, 10).Value
    Else
    End If
    Next
Dim t As Integer
For t = 6 To 155
    If Cells(t, 11).Value <> Cells(t, 37).Value Then
    Cells(t, 37).Value = Cells(t, 11).Value
    Else
    End If
    Next
Dim u As Integer
For u = 6 To 155
    If Cells(u, 12).Value <> Cells(u, 38).Value Then
    Cells(u, 38).Value = Cells(u, 12).Value
    Else
    End If
    Next
Dim w As Integer
For w = 6 To 155
    If Cells(w, 13).Value <> Cells(w, 39).Value Then
    Cells(w, 39).Value = Cells(w, 13).Value
    Else
    End If
    Next
Dim x As Integer
For x = 6 To 155
    If Cells(x, 14).Value <> Cells(x, 40).Value Then
    Cells(x, 40).Value = Cells(x, 14).Value
    Else
    End If
    Next
Dim y As Integer
For y = 6 To 155
    If Cells(y, 15).Value <> Cells(y, 41).Value Then
    Cells(y, 41).Value = Cells(y, 15).Value
    Else
    End If
    Next
Dim z As Integer
For z = 6 To 155
    If Cells(z, 16).Value <> Cells(z, 42).Value Then
    Cells(z, 42).Value = Cells(z, 16).Value
    Else
    End If
    Next
Dim a As Integer
For a = 6 To 155
    If Cells(a, 17).Value <> Cells(a, 43).Value Then
    Cells(a, 43).Value = Cells(a, 17).Value
    Else
    End If
    Next
Dim b As Integer
For b = 6 To 155
    If Cells(b, 18).Value <> Cells(b, 44).Value Then
    Cells(b, 44).Value = Cells(b, 18).Value
    Else
    End If
    Next
Dim c As Integer
For c = 6 To 155
    If Cells(c, 19).Value <> Cells(c, 45).Value Then
    Cells(c, 45).Value = Cells(c, 19).Value
    Else
    End If
    Next
Dim d As Integer
For d = 6 To 155
    If Cells(d, 20).Value <> Cells(d, 46).Value Then
    Cells(d, 46).Value = Cells(d, 20).Value
    Else
    End If
    Next
Dim e As Integer
For e = 6 To 155
    If Cells(e, 21).Value <> Cells(e, 47).Value Then
    Cells(e, 47).Value = Cells(e, 21).Value
    Else
    End If
    Next
Dim f As Integer
For f = 6 To 155
    If Cells(f, 22).Value <> Cells(f, 48).Value Then
    Cells(f, 48).Value = Cells(f, 22).Value
    Else
    End If
    Next
Dim g As Integer
For g = 6 To 155
    If Cells(g, 23).Value <> Cells(g, 49).Value Then
    Cells(g, 49).Value = Cells(g, 23).Value
    Else
    End If
    Next
Dim h As Integer
For h = 6 To 155
    If Cells(h, 24).Value <> Cells(h, 50).Value Then
    Cells(h, 50).Value = Cells(h, 24).Value
    Else
    End If
    Next
Dim i As Integer
For i = 6 To 155
    If Cells(i, 25).Value <> Cells(i, 51).Value Then
    Cells(i, 51).Value = Cells(i, 25).Value
    Else
    End If
    Next
    Call ScheduleTrackingOn
Application.ScreenUpdating = True
End Sub
Sub auto_close()
    On Error Resume Next
    Application.OnTime TimeToRun, "TrackingOn", , False
End Sub
Post Edited
CODE Tags: You must add [CODE][/CODE] tags around your code! (click the CODE button to do this when creating a post)
Answer
Discuss

Discussion

Hi Marciz and welcome to the Forum.

Apologies but I posted an answer then noticed your file (so removed my answer).

What's the purpose of this file? Currently gets you into an endless loop of slow updates (with recalculation of 3600 random numbers every second) which will all approach 1 as you capture their maxima, since you use the worksheet function Rand() in those cells.

I don't have time to look at this but please reply to the above and I will try tomorrow or Monday.
John_Ru (rep: 3677) Jul 2, '22 at 10:51 am
Hi John, Thanks alot for your attention n time spared on my issue. The purpose of the file is just to track every changes on any cell within range B6:Y155, and instantly record the change value, cell address(where change occured), date&time(of change). Your help will be hioghly solicted if solved this issue and in addition there is one more issue which needs to be addressed a solution, that is whenever I switch to another worksheet like from active 'TDatas' to 'Tracker' the macro pause n stopped to work until I switch back to 'TDatas' sheet.....hoping for a solution...Thanks once again....
marciznewbie (rep: 2) Jul 3, '22 at 6:45 am
Hi Marciz

I meant what's the real purpose of recording those changes? (You're testing with random numbers and getting their maximum but that will just lead to a lot of values near 1). Is your range B6:Y155 updated by some remote process (given it changes when you're looking at the TDatas sheet for example)?
John_Ru (rep: 3677) Jul 3, '22 at 7:51 am
Hi John, yes exactly B6:Y155 datas will be remote one. And Exactly I need to monitor what data was fed to me seconds by second....
marciznewbie (rep: 2) Jul 3, '22 at 11:10 pm
Marciz

By using arrays instead, my old PC can just about record 3,600 changes in under a second but there's a quirk I can't quite work out. Also I wanted to record movement ("Increased" or "Decreased") against each change in your tracker sheet but that pushes it over a second (for me). I'll see if I can resolve that quirk (but it makes no sense at present!)
John_Ru (rep: 3677) Jul 5, '22 at 6:50 am
wow...! thats an achievement John....can you let me go through your modified code...
marciznewbie (rep: 2) Jul 6, '22 at 1:55 am
Add to Discussion

Answers

0
Selected Answer

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.

Discuss

Discussion

Forgot to say I changed the macro to speed it up more (by writing changes to an array too)
John_Ru (rep: 3677) Jul 6, '22 at 10:54 am
Please see improved Answer/ file
John_Ru (rep: 3677) Jul 7, '22 at 4:38 am
I've now asked a question on that quirk, under Range.Offset produces incorrect cell address

@Don - I'm hoping you can fix my error!
John_Ru (rep: 3677) Jul 7, '22 at 5:15 am
John, Thanks alot..I had trial run of your modified macro today. And so far it is running fine.....I'll try modify it further to achieve max speed. Thanks once again ...
marciznewbie (rep: 2) Jul 7, '22 at 9:37 am
Thanks for selecting my Answer Marciz.  I'm guessing from your initial macro that your VBA experience is limited.so the only thing I can think of to improve speed further is to remove the colour fill lines and to use real data.
John_Ru (rep: 3677) Jul 7, '22 at 9:58 am
That said, I can't still work out why the row headed 4 causes problems!
John_Ru (rep: 3677) Jul 7, '22 at 9:58 am
You forgot to mark my Answer as Selected (and it was quite a bit of work) :(
John_Ru (rep: 3677) Jul 7, '22 at 10:02 am
Thanks for selecting my answer, Marciz
John_Ru (rep: 3677) Jul 8, '22 at 1:45 am
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login