Macro Speed Optimization

Vbalearner85

Board Regular
Joined
Jun 9, 2019
Messages
121
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

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,976
Office Version
  1. 2010
Platform
  1. Windows
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
 
Solution

Vbalearner85

Board Regular
Joined
Jun 9, 2019
Messages
121
Office Version
  1. 2016
Platform
  1. Windows
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
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.
 

johnnyL

Well-known Member
Joined
Nov 7, 2011
Messages
1,315
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
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
 

Vbalearner85

Board Regular
Joined
Jun 9, 2019
Messages
121
Office Version
  1. 2016
Platform
  1. Windows
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
Thanks for your looking into this...At first look/testing, Macro is also super-fast...
 

johnnyL

Well-known Member
Joined
Nov 7, 2011
Messages
1,315
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
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. :(
 

Forum statistics

Threads
1,141,289
Messages
5,705,524
Members
421,399
Latest member
hjweiss00

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
Top