Macro Speed Optimization

V

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
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.

So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 172 rows it is much quicker to load the 172 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),

I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
Practically every line of your code accesses the worksheet. There is so much of it i haven't got the time to rewrite it. However the good news your code is about as slow as you possible make it so you shoud be able to rewrite using array and it will 100 times faster ( I mean about 100)
A loop of 172 is trivial when done entirely in vba
Just as an example of the difference in speed try running these two macros in a blank workbook one uses array the other access the cells in a loop they both do the same calculation and display the same results:
VBA Code: 
Sub slow()
Dim myrange As Range
Dim cell As Range
Dim elasped As Double

starttim = Timer()
i = 1
Set myrange = Range("A1:D100")
For Each cell In myrange
 cell = i + 1
 i = i + 1
Next cell
elaspsed = 1000 * (Timer() - starttim)
MsgBox elaspsed & " millisec"


End Sub

Sub fast()
Dim myrange As Variant
Dim cell As Range
Dim elasped As Double

starttim = Timer()
i = 1
 myrange = Range("A1:D100")
For k = 1 To UBound(myrange, 1)
   For j = 1 To UBound(myrange, 2)
     myrange(k, j) = i + 1
      i = i + 1
   Next j
Next k
Range("A1:D100") = myrange

elaspsed = 1000 * (Timer() - starttim)
MsgBox elaspsed & " millisec"
The slow routine takes 156 millisecs on my machine, the fast routine is so fast it comes back with 0 millisecs most of the time
 
Upvote 0
Thanks for the insight..quite interesting to know., but I am not sure if I will be able to re-adapt my macro as per above with self-help. I Will give it a try and will share my revived code in case I am able to do so.
 
Upvote 0
I have now found the time to rewrite your code using variant arrays:
VBA Code: 
Sub test()
If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub

Application.ScreenUpdating = False
    
inarr = Workbooks("Dater").Sheets("Timer").Range("B2:AD173")
For i = 1 To 172
'For Each Cell In Workbooks("Dater").Sheets("Timer").Range("B2:B173")
If (inarr(i, 1) <> inarr(i, 9)) Then
'If Cell.Value <> Cell.Offset(0, 9).Value Then
        
        inarr(i, 7) = Now()
        inarr(i, 9) = inarr(i, 1)
        inarr(i, 8) = inarr(i, 4)
        inarr(i, 10) = inarr(i, 10) + 1
        inarr(i, 24) = 1
        inarr(i, 27) = 0
        inarr(i, 28) = 0
    ElseIf inarr(i, 10) <> inarr(i, 14) And inarr(i, 1) = "LR" Then
        inarr(i, 11) = inarr(i, 11) + 1
    ElseIf inarr(i, 10) <> inarr(i, 14) And inarr(i, 1) = "NR" Then
        inarr(i, 12) = inarr(i, 12) + 1
    ElseIf inarr(i, 10) <> inarr(i, 14) And inarr(i, 1) = "HR" Then
        inarr(i, 13) = inarr(i, 13) + 1
    ElseIf inarr(i, 25) <> inarr(i, 26) Then
        inarr(i, 23) = inarr(i, 2)
        inarr(i, 24) = inarr(i, 24) + 1
        inarr(i, 29) = Now()
    ElseIf inarr(i, 2) < inarr(i, 27) Then
        inarr(i, 27) = inarr(i, 2)
    ElseIf inarr(i, 2) > inarr(i, 28) Then
        inarr(i, 28) = inarr(i, 2)
        
    End If
Next i
Workbooks("Dater").Sheets("Timer").Range("B2:AD173") = 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
 
Upvote 0
offthelip said:
I have now found the time to rewrite your code using variant arrays:
VBA Code: 
Sub test()
If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub

Application.ScreenUpdating = False
   
inarr = Workbooks("Dater").Sheets("Timer").Range("B2:AD173")
For i = 1 To 172
'For Each Cell In Workbooks("Dater").Sheets("Timer").Range("B2:B173")
If (inarr(i, 1) <> inarr(i, 9)) Then
'If Cell.Value <> Cell.Offset(0, 9).Value Then
       
        inarr(i, 7) = Now()
        inarr(i, 9) = inarr(i, 1)
        inarr(i, 8) = inarr(i, 4)
        inarr(i, 10) = inarr(i, 10) + 1
        inarr(i, 24) = 1
        inarr(i, 27) = 0
        inarr(i, 28) = 0
    ElseIf inarr(i, 10) <> inarr(i, 14) And inarr(i, 1) = "LR" Then
        inarr(i, 11) = inarr(i, 11) + 1
    ElseIf inarr(i, 10) <> inarr(i, 14) And inarr(i, 1) = "NR" Then
        inarr(i, 12) = inarr(i, 12) + 1
    ElseIf inarr(i, 10) <> inarr(i, 14) And inarr(i, 1) = "HR" Then
        inarr(i, 13) = inarr(i, 13) + 1
    ElseIf inarr(i, 25) <> inarr(i, 26) Then
        inarr(i, 23) = inarr(i, 2)
        inarr(i, 24) = inarr(i, 24) + 1
        inarr(i, 29) = Now()
    ElseIf inarr(i, 2) < inarr(i, 27) Then
        inarr(i, 27) = inarr(i, 2)
    ElseIf inarr(i, 2) > inarr(i, 28) Then
        inarr(i, 28) = inarr(i, 2)
       
    End If
Next i
Workbooks("Dater").Sheets("Timer").Range("B2:AD173") = 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
Click to expand...


Thanks for being so kind to write it up for me. It would have taken me ages to write a macro in this manner.

I tested the code and I think it is ultra-fast.... the only issue is it is turning formulas(conditions) in the sheet to values. Many conditions which macro is checking is via formulas to other sheets.

Regards,

Vablearner
 
Upvote 0
johnnyL said:
@Vbalearner85 do you have a link to a workbook that we can test
Click to expand...

I am delighted that for your revert.... @ offthelip has advised the above code and seems to be working well except for some minor teething issues. I would like to hold spending your valuable time for now and will reach out as needed
 
Upvote 0
Which columns have got formula in them? because there are two choices: either we need to avoid overwriting the formulae, or we save the formulea and rewrite after. This depends on where the formulae are
 
Upvote 0
There are 5-6 columns having formulas..starting column B Range("B2:B173"), columns C-D, Columns Z-AB .This macro is required to keep track of changes every second and act accordingly with its steps and keeping formulas intact is one of key requirement

Else I have to copy data another sheet for those columns every sec..
Regards
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

The Ruff Report
  • Question
Help adjusting Macro to email multiple cc addresses
Replies
1
Views
376
The Ruff Report
The Ruff Report
D
  • Solved
TextBox looping help required in VBA
Replies
3
Views
384
DanteAmor
DanteAmor
Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
341
Agnarr
Agnarr
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
396
Legacy 352679
L
S
  • Solved
VBA: Am I double-calling a Sub given nested If statements? Or other inefficiencies?
Replies
8
Views
244
dreid1011
dreid1011

Forum statistics

Threads
1,214,827
Messages
6,121,821
Members
449,049
Latest member
cybersurfer5000

Share this page

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