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
 
Sort by date Sort by votes

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
This solution uses two different output arrays to write into the columns which don't hold formula. ( ie. the soluition that avoids overwriting the formula) this solution still only accesses the worksheet 6 times in total so it will still extremely fast, unlike any solution that accesses the workhseet multiple time in a loop . Do check data is writen in the correct columns because i could have got the offsets wrong
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")
outG2Z = Workbooks("Dater").Sheets("Timer").Range("G2:Z173")
outAC2AE = Workbooks("Dater").Sheets("Timer").Range("AC2: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
        
        outG2Z(i, 8 - 5) = Now() ' I
        outG2Z(i, 10 - 5) = inarr(i, 1) 'K
        outG2Z(i, 9 - 5) = inarr(i, 5) 'J
        outG2Z(i, 11 - 5) = inarr(i, 11) + 1 'L
        outG2Z(i, 25 - 5) = 1 'Z
        outAC2AE(i, 28 - 27) = 0 ' AC
        outAC2AE(i, 29 - 27) = 0 'AD
    ElseIf inarr(i, 11) <> inarr(i, 12) + inarr(i, 13) + inarr(i, 14) And inarr(i, 1) = "LR" Then
        outG2Z(i, 12) = inarr(i, 12) + 1  'M
    ElseIf inarr(i, 11) <> inarr(i, 12) + inarr(i, 13) + inarr(i, 14) And inarr(i, 1) = "NR" Then
        outG2Z(i, 13) = inarr(i, 13) + 1  'N
    ElseIf inarr(i, 11) <> inarr(i, 12) + inarr(i, 13) + inarr(i, 14) And inarr(i, 1) = "HR" Then
        outG2Z(i, 14) = inarr(i, 14) + 1  'O
    ElseIf inarr(i, 26) <> inarr(i, 27) Then
        outG2Z(i, 24) = inarr(i, 3) 'Y
        outG2Z(i, 25) = inarr(i, 25) + 1 'Z
        outAC2AE(i, 30) = Now()   ' AE
    ElseIf inarr(i, 3) < inarr(i, 28) Then
        outAC2AE(i, 28 - 27) = inarr(i, 3) 'AC
    ElseIf inarr(i, 3) > inarr(i, 29) Then
        outAC2AE(i, 29 - 27) = inarr(i, 3) 'AD
        
    End If
Next i
 Workbooks("Dater").Sheets("Timer").Range("G2:Z173") = outG2Z
Workbooks("Dater").Sheets("Timer").Range("AC2:AE173") = outAC2AE
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
Solution
offthelip said:
This solution uses two different output arrays to write into the columns which don't hold formula. ( ie. the soluition that avoids overwriting the formula) this solution still only accesses the worksheet 6 times in total so it will still extremely fast, unlike any solution that accesses the workhseet multiple time in a loop . Do check data is writen in the correct columns because i could have got the offsets wrong
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")
outG2Z = Workbooks("Dater").Sheets("Timer").Range("G2:Z173")
outAC2AE = Workbooks("Dater").Sheets("Timer").Range("AC2: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
       
        outG2Z(i, 8 - 5) = Now() ' I
        outG2Z(i, 10 - 5) = inarr(i, 1) 'K
        outG2Z(i, 9 - 5) = inarr(i, 5) 'J
        outG2Z(i, 11 - 5) = inarr(i, 11) + 1 'L
        outG2Z(i, 25 - 5) = 1 'Z
        outAC2AE(i, 28 - 27) = 0 ' AC
        outAC2AE(i, 29 - 27) = 0 'AD
    ElseIf inarr(i, 11) <> inarr(i, 12) + inarr(i, 13) + inarr(i, 14) And inarr(i, 1) = "LR" Then
        outG2Z(i, 12) = inarr(i, 12) + 1  'M
    ElseIf inarr(i, 11) <> inarr(i, 12) + inarr(i, 13) + inarr(i, 14) And inarr(i, 1) = "NR" Then
        outG2Z(i, 13) = inarr(i, 13) + 1  'N
    ElseIf inarr(i, 11) <> inarr(i, 12) + inarr(i, 13) + inarr(i, 14) And inarr(i, 1) = "HR" Then
        outG2Z(i, 14) = inarr(i, 14) + 1  'O
    ElseIf inarr(i, 26) <> inarr(i, 27) Then
        outG2Z(i, 24) = inarr(i, 3) 'Y
        outG2Z(i, 25) = inarr(i, 25) + 1 'Z
        outAC2AE(i, 30) = Now()   ' AE
    ElseIf inarr(i, 3) < inarr(i, 28) Then
        outAC2AE(i, 28 - 27) = inarr(i, 3) 'AC
    ElseIf inarr(i, 3) > inarr(i, 29) Then
        outAC2AE(i, 29 - 27) = inarr(i, 3) 'AD
       
    End If
Next i
 Workbooks("Dater").Sheets("Timer").Range("G2:Z173") = outG2Z
Workbooks("Dater").Sheets("Timer").Range("AC2:AE173") = outAC2AE
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...
Sir, the macro works like a charm. As promised......it is ultra-fast like a bullet train. Thanks so much for sharing your skills and time :) :)

I just repurposed some of the cells/columns references as per my need.
 
Upvote 0
Please try this also, for giggles:

VBA Code: 
Sub TimerV4()
'
'   This macro is practically totally array driven now
'
    Application.ScreenUpdating = False
'
'   Dimension One Dimensional Arrays
    Dim SheetsTimerB_Array()    As Variant
    Dim SheetsTimerD_Array()    As Variant
    Dim SheetsTimerF_Array()    As Variant
    Dim SheetsTimerP_Array()    As Variant
    Dim SheetsTimerAA_Array()   As Variant
    Dim SheetsTimerAB_Array()   As Variant
'
'   Dimension Two Dimensional Arrays
    Dim ColumnsI_Thru_O_ArrayToWrite    As Variant
    Dim ColumnsY_Thru_Z_ArrayToWrite    As Variant
    Dim ColumnsAC_Thru_AE_ArrayToWrite  As Variant
'
    If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub
'
'   Load One Dimensional Arrays
     SheetsTimerB_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("B2:B173"))
     SheetsTimerD_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("D2:D173"))
     SheetsTimerF_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("F2:F173"))
     SheetsTimerP_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("P2:P173"))
    SheetsTimerAA_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AA2:AA173"))
    SheetsTimerAB_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AB2:AB173"))
'
'   Load Two Dimensional Arrays
    ColumnsI_Thru_O_ArrayToWrite = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("I2:O173"))
    ColumnsY_Thru_Z_ArrayToWrite = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("Y2:Z173"))
    ColumnsAC_Thru_AE_ArrayToWrite = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AC2:AE173"))
'
    For LoopCounter = 1 To UBound(SheetsTimerB_Array)
        If SheetsTimerB_Array(LoopCounter) <> ColumnsI_Thru_O_ArrayToWrite(3, LoopCounter) Then
            ColumnsI_Thru_O_ArrayToWrite(1, LoopCounter) = Now                                                  ' Column I
            ColumnsI_Thru_O_ArrayToWrite(2, LoopCounter) = SheetsTimerF_Array(LoopCounter)                      ' Column J
            ColumnsI_Thru_O_ArrayToWrite(3, LoopCounter) = SheetsTimerB_Array(LoopCounter)                      ' Column K
            ColumnsI_Thru_O_ArrayToWrite(4, LoopCounter) = ColumnsI_Thru_O_ArrayToWrite(4, LoopCounter) + 1     ' Column L
            ColumnsY_Thru_Z_ArrayToWrite(2, LoopCounter) = 1                                                    ' Column Z
            ColumnsAC_Thru_AE_ArrayToWrite(1, LoopCounter) = 0                                                  ' Column AC
            ColumnsAC_Thru_AE_ArrayToWrite(2, LoopCounter) = 0                                                  ' Column AD
'
        ElseIf ColumnsI_Thru_O_ArrayToWrite(4, LoopCounter) <> SheetsTimerP_Array(LoopCounter) And SheetsTimerB_Array(LoopCounter) = "LR" Then
             ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) = ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) + 1    ' Column M
'
        ElseIf ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) <> SheetsTimerP_Array(LoopCounter) And SheetsTimerB_Array(LoopCounter) = "NR" Then
            ColumnsI_Thru_O_ArrayToWrite(6, LoopCounter) = ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) + 1     ' Column N
'
        ElseIf ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) <> SheetsTimerP_Array(LoopCounter) And SheetsTimerB_Array(LoopCounter) = "HR" Then
            ColumnsI_Thru_O_ArrayToWrite(7, LoopCounter) = ColumnsI_Thru_O_ArrayToWrite(7, LoopCounter) + 1     ' Column O
'
        ElseIf SheetsTimerAA_Array(LoopCounter) <> SheetsTimerAB_Array(LoopCounter) Then
            ColumnsY_Thru_Z_ArrayToWrite(1, LoopCounter) = SheetsTimerD_Array(LoopCounter)                      ' Column Y
            ColumnsY_Thru_Z_ArrayToWrite(2, LoopCounter) = ColumnsY_Thru_Z_ArrayToWrite(2, LoopCounter) + 1     ' Column Z
            ColumnsAC_Thru_AE_ArrayToWrite(3, LoopCounter) = Now                                                ' Column AE
'
        ElseIf SheetsTimerD_Array(LoopCounter) < ColumnsAC_Thru_AE_ArrayToWrite(1, LoopCounter) Then
            ColumnsAC_Thru_AE_ArrayToWrite(1, LoopCounter) = SheetsTimerD_Array(LoopCounter)                    ' Column AC
'
        Else
            If SheetsTimerD_Array(LoopCounter) > ColumnsAC_Thru_AE_ArrayToWrite(2, LoopCounter) Then
                ColumnsAC_Thru_AE_ArrayToWrite(2, LoopCounter) = SheetsTimerD_Array(LoopCounter)                ' Column AD
            End If
        End If
    Next
'
    Workbooks("Dater").Sheets("Timer").Range("I2:O173") = Application.Transpose(ColumnsI_Thru_O_ArrayToWrite)
    Workbooks("Dater").Sheets("Timer").Range("Y2:Z173") = Application.Transpose(ColumnsY_Thru_Z_ArrayToWrite)
    Workbooks("Dater").Sheets("Timer").Range("AC2:AE173") = Application.Transpose(ColumnsAC_Thru_AE_ArrayToWrite)
'
    Columns("I:I").EntireColumn.AutoFit
'
    Call Timer5
'
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
johnnyL said:
Please try this also, for giggles:

VBA Code: 
Sub TimerV4()
'
'   This macro is practically totally array driven now
'
    Application.ScreenUpdating = False
'
'   Dimension One Dimensional Arrays
    Dim SheetsTimerB_Array()    As Variant
    Dim SheetsTimerD_Array()    As Variant
    Dim SheetsTimerF_Array()    As Variant
    Dim SheetsTimerP_Array()    As Variant
    Dim SheetsTimerAA_Array()   As Variant
    Dim SheetsTimerAB_Array()   As Variant
'
'   Dimension Two Dimensional Arrays
    Dim ColumnsI_Thru_O_ArrayToWrite    As Variant
    Dim ColumnsY_Thru_Z_ArrayToWrite    As Variant
    Dim ColumnsAC_Thru_AE_ArrayToWrite  As Variant
'
    If Time >= ThisWorkbook.Sheets("Control").Range("E17").Value2 Then Exit Sub
'
'   Load One Dimensional Arrays
     SheetsTimerB_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("B2:B173"))
     SheetsTimerD_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("D2:D173"))
     SheetsTimerF_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("F2:F173"))
     SheetsTimerP_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("P2:P173"))
    SheetsTimerAA_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AA2:AA173"))
    SheetsTimerAB_Array = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AB2:AB173"))
'
'   Load Two Dimensional Arrays
    ColumnsI_Thru_O_ArrayToWrite = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("I2:O173"))
    ColumnsY_Thru_Z_ArrayToWrite = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("Y2:Z173"))
    ColumnsAC_Thru_AE_ArrayToWrite = Application.Transpose(Workbooks("Dater").Sheets("Timer").Range("AC2:AE173"))
'
    For LoopCounter = 1 To UBound(SheetsTimerB_Array)
        If SheetsTimerB_Array(LoopCounter) <> ColumnsI_Thru_O_ArrayToWrite(3, LoopCounter) Then
            ColumnsI_Thru_O_ArrayToWrite(1, LoopCounter) = Now                                                  ' Column I
            ColumnsI_Thru_O_ArrayToWrite(2, LoopCounter) = SheetsTimerF_Array(LoopCounter)                      ' Column J
            ColumnsI_Thru_O_ArrayToWrite(3, LoopCounter) = SheetsTimerB_Array(LoopCounter)                      ' Column K
            ColumnsI_Thru_O_ArrayToWrite(4, LoopCounter) = ColumnsI_Thru_O_ArrayToWrite(4, LoopCounter) + 1     ' Column L
            ColumnsY_Thru_Z_ArrayToWrite(2, LoopCounter) = 1                                                    ' Column Z
            ColumnsAC_Thru_AE_ArrayToWrite(1, LoopCounter) = 0                                                  ' Column AC
            ColumnsAC_Thru_AE_ArrayToWrite(2, LoopCounter) = 0                                                  ' Column AD
'
        ElseIf ColumnsI_Thru_O_ArrayToWrite(4, LoopCounter) <> SheetsTimerP_Array(LoopCounter) And SheetsTimerB_Array(LoopCounter) = "LR" Then
             ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) = ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) + 1    ' Column M
'
        ElseIf ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) <> SheetsTimerP_Array(LoopCounter) And SheetsTimerB_Array(LoopCounter) = "NR" Then
            ColumnsI_Thru_O_ArrayToWrite(6, LoopCounter) = ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) + 1     ' Column N
'
        ElseIf ColumnsI_Thru_O_ArrayToWrite(5, LoopCounter) <> SheetsTimerP_Array(LoopCounter) And SheetsTimerB_Array(LoopCounter) = "HR" Then
            ColumnsI_Thru_O_ArrayToWrite(7, LoopCounter) = ColumnsI_Thru_O_ArrayToWrite(7, LoopCounter) + 1     ' Column O
'
        ElseIf SheetsTimerAA_Array(LoopCounter) <> SheetsTimerAB_Array(LoopCounter) Then
            ColumnsY_Thru_Z_ArrayToWrite(1, LoopCounter) = SheetsTimerD_Array(LoopCounter)                      ' Column Y
            ColumnsY_Thru_Z_ArrayToWrite(2, LoopCounter) = ColumnsY_Thru_Z_ArrayToWrite(2, LoopCounter) + 1     ' Column Z
            ColumnsAC_Thru_AE_ArrayToWrite(3, LoopCounter) = Now                                                ' Column AE
'
        ElseIf SheetsTimerD_Array(LoopCounter) < ColumnsAC_Thru_AE_ArrayToWrite(1, LoopCounter) Then
            ColumnsAC_Thru_AE_ArrayToWrite(1, LoopCounter) = SheetsTimerD_Array(LoopCounter)                    ' Column AC
'
        Else
            If SheetsTimerD_Array(LoopCounter) > ColumnsAC_Thru_AE_ArrayToWrite(2, LoopCounter) Then
                ColumnsAC_Thru_AE_ArrayToWrite(2, LoopCounter) = SheetsTimerD_Array(LoopCounter)                ' Column AD
            End If
        End If
    Next
'
    Workbooks("Dater").Sheets("Timer").Range("I2:O173") = Application.Transpose(ColumnsI_Thru_O_ArrayToWrite)
    Workbooks("Dater").Sheets("Timer").Range("Y2:Z173") = Application.Transpose(ColumnsY_Thru_Z_ArrayToWrite)
    Workbooks("Dater").Sheets("Timer").Range("AC2:AE173") = Application.Transpose(ColumnsAC_Thru_AE_ArrayToWrite)
'
    Columns("I:I").EntireColumn.AutoFit
'
    Call Timer5
'
    Application.ScreenUpdating = True
End Sub
Click to expand...
Thanks for your looking into this...At first look/testing, Macro is also super-fast...
 
Upvote 0
Cool. This is the most array driven macro I have ever written. It would be nice to have some test data to test it against to get some actual timings, and therefor possibly improve on it, but we deal with what we have at hand I guess. :(
 
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
378
The Ruff Report
The Ruff Report
D
  • Solved
TextBox looping help required in VBA
Replies
3
Views
385
DanteAmor
DanteAmor
Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
345
Agnarr
Agnarr
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
398
Legacy 352679
L
S
  • Solved
VBA: Am I double-calling a Sub given nested If statements? Or other inefficiencies?
Replies
8
Views
247
dreid1011
dreid1011

Forum statistics

Threads
1,214,918
Messages
6,122,246
Members
449,075
Latest member
staticfluids

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