Macro Speed Optimization

Vbalearner85

Board Regular
Joined
Jun 9, 2019
Messages
139
Office Version
  1. 2016
Platform
  1. Windows
Hi Members,

I have the below macro which I am using for my Timer/values copy purpose and has served my purpose well until now. Off late I am seeing some speed Issues and excel goes to "Not responding" several times. In combination, I am using the "Timer5" macro - Application. Ontine method (used in below macro) to loop below macro every second.

Looking for suggestions as to if I can optimize the macro for speed or if I am doing something wrong fundamentally.

Please note that:-

1. the conditions in the said macro used Range("B2:B173") are met for most of the cells per second and macro is doing some busy work.
2. Some other Copy. Paste Data macros are also used to copy some data per second from one sheet to another (1 second Loop) and these macros have synced well historically.

VBA Code:
Sub Timer()
If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub

Dim Cell As Range
Application.ScreenUpdating = False
    

For Each Cell In Workbooks("Dater").Sheets("Timer").Range("B2:B173")
If Cell.Value <> Cell.Offset(0, 9).Value Then
        Cell.Offset(0, 7).Value = Now
        Cell.Offset(0, 9).Value = Cell.Value
        Cell.Offset(0, 8).Value = Cell.Offset(0, 4).Value
        Cell.Offset(0, 10).Value = Cell.Offset(0, 10).Value + 1
        Cell.Offset(0, 24).Value = 1
        Cell.Offset(0, 27).Value = 0
        Cell.Offset(0, 28).Value = 0
    ElseIf Cell.Offset(0, 10).Value <> Cell.Offset(0, 14).Value And Cell.Value = "LR" Then
        Cell.Offset(0, 11).Value = Cell.Offset(0, 11).Value + 1
    ElseIf Cell.Offset(0, 10).Value <> Cell.Offset(0, 14).Value And Cell.Value = "NR" Then
        Cell.Offset(0, 12).Value = Cell.Offset(0, 12).Value + 1
    ElseIf Cell.Offset(0, 10).Value <> Cell.Offset(0, 14).Value And Cell.Value = "HR" Then
        Cell.Offset(0, 13).Value = Cell.Offset(0, 13).Value + 1
    ElseIf Cell.Offset(0, 25).Value <> Cell.Offset(0, 26).Value Then
        Cell.Offset(0, 23).Value = Cell.Offset(0, 2).Value
        Cell.Offset(0, 24).Value = Cell.Offset(0, 24).Value + 1
        Cell.Offset(0, 29).Value = Now
    ElseIf Cell.Offset(0, 2).Value < Cell.Offset(0, 27).Value Then
        Cell.Offset(0, 27).Value = Cell.Offset(0, 2).Value
    ElseIf Cell.Offset(0, 2).Value > Cell.Offset(0, 28).Value Then
        Cell.Offset(0, 28).Value = Cell.Offset(0, 2).Value
        
    End If
Next
Columns("I:I").EntireColumn.AutoFit
Call Timer5

Application.ScreenUpdating = True
End Sub
 
Column Z has formulas? what part?
Adding Sample Image. Not sure how I can upload sample excel.
Yellow marked ones are using formulas. Also, I made slight changes to the column cells reference in macro provided by @offthelip above to sync as per my old macro.

Revised MAcro is as attached (only changes column reference by 1 for each line)

VBA Code:
Sub Timer()

If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub

Application.ScreenUpdating = False
    
inarr = Workbooks("Dater").Sheets("Timer").Range("B2:AE173")
For i = 1 To 172
'For Each Cell In Workbooks("Dater").Sheets("Timer").Range("B2:B173")
If (inarr(i, 1) <> inarr(i, 10)) Then
'If Cell.Value <> Cell.Offset(0, 9).Value Then
        
        inarr(i, 8) = Now()
        inarr(i, 10) = inarr(i, 1)
        inarr(i, 9) = inarr(i, 5)
        inarr(i, 11) = inarr(i, 11) + 1
        inarr(i, 25) = 1
        inarr(i, 28) = 0
        inarr(i, 29) = 0
    ElseIf inarr(i, 11) <> inarr(i, 12) + inarr(i, 13) + inarr(i, 14) And inarr(i, 1) = "LR" Then
        inarr(i, 12) = inarr(i, 12) + 1
    ElseIf inarr(i, 11) <> inarr(i, 12) + inarr(i, 13) + inarr(i, 14) And inarr(i, 1) = "NR" Then
        inarr(i, 13) = inarr(i, 13) + 1
    ElseIf inarr(i, 11) <> inarr(i, 12) + inarr(i, 13) + inarr(i, 14) And inarr(i, 1) = "HR" Then
        inarr(i, 14) = inarr(i, 14) + 1
    ElseIf inarr(i, 26) <> inarr(i, 27) Then
        inarr(i, 24) = inarr(i, 3)
        inarr(i, 25) = inarr(i, 25) + 1
        inarr(i, 30) = Now()
    ElseIf inarr(i, 3) < inarr(i, 28) Then
        inarr(i, 28) = inarr(i, 3)
    ElseIf inarr(i, 3) > inarr(i, 29) Then
        inarr(i, 29) = inarr(i, 3)
        
    End If
Next i
Workbooks("Dater").Sheets("Timer").Range("B2:AE173") = inarr
Columns("I:I").EntireColumn.AutoFit  ' for real speed I recommend setting the width once outside the macro
Call Timer5

Application.ScreenUpdating = True
End Sub
 

Attachments

  • Sample.JPG
    Sample.JPG
    50.1 KB · Views: 6
Last edited:
Upvote 0

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Your image does not show formulas in column Z.
Yes, You are right ...my Bad. Column Z does not have formulas. Only yellow highlighted ones are needed from a formulas perspective and if it helps...formulas columns can be brought together/rearranged in in terms of range and accordingly Macro can be modified to perform
 
Upvote 0
Ok. Try the following:

VBA Code:
Sub TimerV2()
'
    Application.ScreenUpdating = False
'
    Dim SheetsTimerBArray()     As Variant
    Dim SheetsTimerDArray()     As Variant
    Dim SheetsTimerPArray()     As Variant
    Dim SheetsTimerAAArray()    As Variant
    Dim SheetsTimerABArray()    As Variant
'
    If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub
'
     SheetsTimerBArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("B2:B173"))
     SheetsTimerDArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("D2:D173"))
     SheetsTimerPArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("P2:P173"))
    SheetsTimerAAArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AA2:AA173"))
    SheetsTimerABArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AB2:AB173"))
'
    For LoopCounter = 1 To UBound(SheetsTimerBArray)
        If SheetsTimerBArray(LoopCounter).Value <> Range("K" & LoopCounter + 1).Value Then
             Range("I" & LoopCounter + 1).Value = Now
             Range("K" & LoopCounter + 1).Value = SheetsTimerBArray(LoopCounter).Value
             Range("J" & LoopCounter + 1).Value = Range("F" & LoopCounter + 1).Value
             Range("L" & LoopCounter + 1).Value = Range("L" & LoopCounter + 1).Value + 1
             Range("Z" & LoopCounter + 1).Value = 1
            Range("AC" & LoopCounter + 1).Value = 0
            Range("AD" & LoopCounter + 1).Value = 0
'
        ElseIf Range("L" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter).Value And SheetsTimerBArray(LoopCounter).Value = "LR" Then
            Range("M" & LoopCounter + 1).Value = Range("M" & LoopCounter + 1).Value + 1
'
        ElseIf Range("M" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter).Value And SheetsTimerBArray(LoopCounter).Value = "NR" Then
            Range("N" & LoopCounter + 1).Value = Range("N" & LoopCounter + 1).Value + 1
'
        ElseIf Range("M" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter).Value And SheetsTimerBArray(LoopCounter).Value = "HR" Then
            Range("O" & LoopCounter + 1).Value = Range("O" & LoopCounter + 1).Value + 1
'
        ElseIf SheetsTimerAAArray(LoopCounter).Value <> SheetsTimerABArray(LoopCounter).Value Then
            Range("Y" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter).Value
            Range("Z" & LoopCounter + 1).Value = Range("Z" & LoopCounter + 1).Value + 1
            Range("AE" & LoopCounter + 1).Value = Now
'
        ElseIf SheetsTimerDArray(LoopCounter).Value < Range("AC" & LoopCounter + 1).Value Then
            Range("AC" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter).Value
'
        Else
            If SheetsTimerDArray(LoopCounter).Value > Range("AD" & LoopCounter + 1).Value Then
                Range("AD" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter).Value
            End If
        End If
    Next
'
    Columns("I:I").EntireColumn.AutoFit
'
    Call Timer5
'
    Application.ScreenUpdating = True
End Sub

This code is based on the code in post #1.
 
Upvote 0
Ok. Try the following:

VBA Code:
Sub TimerV2()
'
    Application.ScreenUpdating = False
'
    Dim SheetsTimerBArray()     As Variant
    Dim SheetsTimerDArray()     As Variant
    Dim SheetsTimerPArray()     As Variant
    Dim SheetsTimerAAArray()    As Variant
    Dim SheetsTimerABArray()    As Variant
'
    If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub
'
     SheetsTimerBArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("B2:B173"))
     SheetsTimerDArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("D2:D173"))
     SheetsTimerPArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("P2:P173"))
    SheetsTimerAAArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AA2:AA173"))
    SheetsTimerABArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AB2:AB173"))
'
    For LoopCounter = 1 To UBound(SheetsTimerBArray)
        If SheetsTimerBArray(LoopCounter).Value <> Range("K" & LoopCounter + 1).Value Then
             Range("I" & LoopCounter + 1).Value = Now
             Range("K" & LoopCounter + 1).Value = SheetsTimerBArray(LoopCounter).Value
             Range("J" & LoopCounter + 1).Value = Range("F" & LoopCounter + 1).Value
             Range("L" & LoopCounter + 1).Value = Range("L" & LoopCounter + 1).Value + 1
             Range("Z" & LoopCounter + 1).Value = 1
            Range("AC" & LoopCounter + 1).Value = 0
            Range("AD" & LoopCounter + 1).Value = 0
'
        ElseIf Range("L" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter).Value And SheetsTimerBArray(LoopCounter).Value = "LR" Then
            Range("M" & LoopCounter + 1).Value = Range("M" & LoopCounter + 1).Value + 1
'
        ElseIf Range("M" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter).Value And SheetsTimerBArray(LoopCounter).Value = "NR" Then
            Range("N" & LoopCounter + 1).Value = Range("N" & LoopCounter + 1).Value + 1
'
        ElseIf Range("M" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter).Value And SheetsTimerBArray(LoopCounter).Value = "HR" Then
            Range("O" & LoopCounter + 1).Value = Range("O" & LoopCounter + 1).Value + 1
'
        ElseIf SheetsTimerAAArray(LoopCounter).Value <> SheetsTimerABArray(LoopCounter).Value Then
            Range("Y" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter).Value
            Range("Z" & LoopCounter + 1).Value = Range("Z" & LoopCounter + 1).Value + 1
            Range("AE" & LoopCounter + 1).Value = Now
'
        ElseIf SheetsTimerDArray(LoopCounter).Value < Range("AC" & LoopCounter + 1).Value Then
            Range("AC" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter).Value
'
        Else
            If SheetsTimerDArray(LoopCounter).Value > Range("AD" & LoopCounter + 1).Value Then
                Range("AD" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter).Value
            End If
        End If
    Next
'
    Columns("I:I").EntireColumn.AutoFit
'
    Call Timer5
'
    Application.ScreenUpdating = True
End Sub

This code is based on the code in post #1.
Macro gives Run time error 424 - object required and stops on below line

If SheetsTimerBArray(LoopCounter).Value <> Range("K" & LoopCounter + 1).Value Then

Regards
 
Upvote 0
How about:

VBA Code:
Sub TimerV3()
'
    Application.ScreenUpdating = False
'
    Dim SheetsTimerBArray()     As Variant
    Dim SheetsTimerDArray()     As Variant
    Dim SheetsTimerPArray()     As Variant
    Dim SheetsTimerAAArray()    As Variant
    Dim SheetsTimerABArray()    As Variant
'
    If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub
'
     SheetsTimerBArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("B2:B173"))
     SheetsTimerDArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("D2:D173"))
     SheetsTimerPArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("P2:P173"))
    SheetsTimerAAArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AA2:AA173"))
    SheetsTimerABArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AB2:AB173"))
'
    For LoopCounter = 1 To UBound(SheetsTimerBArray)
        If SheetsTimerBArray(LoopCounter) <> Range("K" & LoopCounter + 1).Value Then
             Range("I" & LoopCounter + 1).Value = Now
             Range("K" & LoopCounter + 1).Value = SheetsTimerBArray(LoopCounter)
             Range("J" & LoopCounter + 1).Value = Range("F" & LoopCounter + 1).Value
             Range("L" & LoopCounter + 1).Value = Range("L" & LoopCounter + 1).Value + 1
             Range("Z" & LoopCounter + 1).Value = 1
            Range("AC" & LoopCounter + 1).Value = 0
            Range("AD" & LoopCounter + 1).Value = 0
'
        ElseIf Range("L" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter) And SheetsTimerBArray(LoopCounter) = "LR" Then
            Range("M" & LoopCounter + 1).Value = Range("M" & LoopCounter + 1).Value + 1
'
        ElseIf Range("M" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter) And SheetsTimerBArray(LoopCounter) = "NR" Then
            Range("N" & LoopCounter + 1).Value = Range("N" & LoopCounter + 1).Value + 1
'
        ElseIf Range("M" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter) And SheetsTimerBArray(LoopCounter) = "HR" Then
            Range("O" & LoopCounter + 1).Value = Range("O" & LoopCounter + 1).Value + 1
'
        ElseIf SheetsTimerAAArray(LoopCounter) <> SheetsTimerABArray(LoopCounter) Then
            Range("Y" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter)
            Range("Z" & LoopCounter + 1).Value = Range("Z" & LoopCounter + 1).Value + 1
            Range("AE" & LoopCounter + 1).Value = Now
'
        ElseIf SheetsTimerDArray(LoopCounter) < Range("AC" & LoopCounter + 1).Value Then
            Range("AC" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter)
'
        Else
            If SheetsTimerDArray(LoopCounter) > Range("AD" & LoopCounter + 1).Value Then
                Range("AD" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter)
            End If
        End If
    Next
'
    Columns("I:I").EntireColumn.AutoFit
'
    Call Timer5
'
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
How about:

VBA Code:
Sub TimerV3()
'
    Application.ScreenUpdating = False
'
    Dim SheetsTimerBArray()     As Variant
    Dim SheetsTimerDArray()     As Variant
    Dim SheetsTimerPArray()     As Variant
    Dim SheetsTimerAAArray()    As Variant
    Dim SheetsTimerABArray()    As Variant
'
    If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub
'
     SheetsTimerBArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("B2:B173"))
     SheetsTimerDArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("D2:D173"))
     SheetsTimerPArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("P2:P173"))
    SheetsTimerAAArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AA2:AA173"))
    SheetsTimerABArray = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AB2:AB173"))
'
    For LoopCounter = 1 To UBound(SheetsTimerBArray)
        If SheetsTimerBArray(LoopCounter) <> Range("K" & LoopCounter + 1).Value Then
             Range("I" & LoopCounter + 1).Value = Now
             Range("K" & LoopCounter + 1).Value = SheetsTimerBArray(LoopCounter)
             Range("J" & LoopCounter + 1).Value = Range("F" & LoopCounter + 1).Value
             Range("L" & LoopCounter + 1).Value = Range("L" & LoopCounter + 1).Value + 1
             Range("Z" & LoopCounter + 1).Value = 1
            Range("AC" & LoopCounter + 1).Value = 0
            Range("AD" & LoopCounter + 1).Value = 0
'
        ElseIf Range("L" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter) And SheetsTimerBArray(LoopCounter) = "LR" Then
            Range("M" & LoopCounter + 1).Value = Range("M" & LoopCounter + 1).Value + 1
'
        ElseIf Range("M" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter) And SheetsTimerBArray(LoopCounter) = "NR" Then
            Range("N" & LoopCounter + 1).Value = Range("N" & LoopCounter + 1).Value + 1
'
        ElseIf Range("M" & LoopCounter + 1).Value <> SheetsTimerPArray(LoopCounter) And SheetsTimerBArray(LoopCounter) = "HR" Then
            Range("O" & LoopCounter + 1).Value = Range("O" & LoopCounter + 1).Value + 1
'
        ElseIf SheetsTimerAAArray(LoopCounter) <> SheetsTimerABArray(LoopCounter) Then
            Range("Y" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter)
            Range("Z" & LoopCounter + 1).Value = Range("Z" & LoopCounter + 1).Value + 1
            Range("AE" & LoopCounter + 1).Value = Now
'
        ElseIf SheetsTimerDArray(LoopCounter) < Range("AC" & LoopCounter + 1).Value Then
            Range("AC" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter)
'
        Else
            If SheetsTimerDArray(LoopCounter) > Range("AD" & LoopCounter + 1).Value Then
                Range("AD" & LoopCounter + 1).Value = SheetsTimerDArray(LoopCounter)
            End If
        End If
    Next
'
    Columns("I:I").EntireColumn.AutoFit
'
    Call Timer5
'
    Application.ScreenUpdating = True
End Sub
Stops with same Run time error 424 - object required@ the last line below

VBA Code:
For LoopCounter = 1 To UBound(SheetsTimerBArray)
        If SheetsTimerBArray(LoopCounter) <> Range("K" & LoopCounter + 1).Value Then
            Range("I" & LoopCounter + 1).Value = Now
            Range("K" & LoopCounter + 1).Value = SheetsTimerBArray(LoopCounter).Value
 
Upvote 0
Remove that '.Value' at the end of that last line

You must have copied my post prior to me fixing that line
 
Upvote 0
Remove that '.Value' at the end of that last line

You must have copied my post prior to me fixing that line
Sir works now as per the above modification...Thanks for your time in looking into this.

but the original issue remains..macro takes the almost same time as my original Macro..so defeating Optimization purpose.
 
Upvote 0
I just wanted to make sure everything was lined up for now. I will start on the optimization.
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,557
Latest member
richa mishra

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top