PDA

View Full Version : How to speed up a Change Event Loop



Poundland
01-28-2019, 07:25 AM
Hi Guys,

I have written the below code, the purpose of which is to loop through areas of a worksheet looking for changes and once the change has been found to peform an action or to run another Sub Routine.

The code loops 400 times looking for what has changed, it takes between 1 and 2 seconds to run which includes running the Sub Routine, is there a way that I can make this faster?


Private Sub Worksheet_Change(ByVal Target As Range)


Dim KeyCells As Range
Dim Rw As Long, Col As Long, Rng As Range
Dim shtlf As Worksheet, rngCal As Range, rngVal As Range
Dim pdat As Date, shtDates As Worksheet
Dim rngDate As Range, strDT As String, a As Long
pdat = VBA.Format(Now(), "dd/mm/yyyy")
Set shtlf = ActiveWorkbook.Sheets("Line Flow")
Set shtDates = ActiveWorkbook.Sheets("Dates")
With shtDates
Set rngDate = .Range("A:A")
End With
With rngDate
shtDT = .Find(pdat, , xlValues, xlWhole).Offset(, 2).Value
End With
With shtlf.Rows(6)
Col = .Find(shtDT, , xlValues, xlWhole).Column
End With

' Updating OTB Row
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.

' **************************
' Add Loop for how ever many MSKU are being planned
' **************************

Rw = 9 ' First MSKU, for subsequent MSKU add 48

For a = 1 To 400 ' Loops through all sections
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw, Col), Cells(Rw, Col + 52))
Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Set rngOTBTarget = Target

' sets worksheet object variables
Set shtlf = ActiveWorkbook.Sheets("Line Flow")
Application.EnableEvents = False
'Debug.Print (WorksheetFunction.Sum(KeyCells) & " " & WorksheetFunction.Sum(Target))
'Debug.Print (KeyCells.Address & " " & Target.Address)
If WorksheetFunction.Sum(KeyCells) = 0 And WorksheetFunction.Sum(Target) = 0 Then
shtlf.Range(Cells(Rw + 40, Target.Column).Address, Cells(Rw + 43, Target.Column).End(xlToRight).Address).Value = 0 ' resets the macro destinations to 0
End If
'Application.EnableEvents = True ' testing only
Call New_OTB_Routine
Application.Calculation = xlCalculationManual
End If
' Allocation Row
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 6, Col), Cells(Rw + 6, Col + 52))
'Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
' Override Sales Row
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 10, Col), Cells(Rw + 10, Col + 52))
'Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
' Override Sales Row
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 10, Col), Cells(Rw + 10, Col + 52))
'Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
' Reschedule Rows
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 17, Col), Cells(Rw + 17, Col + 52))
'Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 18, Col), Cells(Rw + 18, Col + 52))
'Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 21, Col), Cells(Rw + 21, Col + 52))
'Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 22, Col), Cells(Rw + 22, Col + 52))
' Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 25, Col), Cells(Rw + 25, Col + 52))
'Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 26, Col), Cells(Rw + 26, Col + 52))
' Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 29, Col), Cells(Rw + 29, Col + 52))
' Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 30, Col), Cells(Rw + 30, Col + 52))
' Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
' WH Cover Target
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 6, 4), Cells(Rw + 6, 4))
' Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
' Profiler
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 8, 3), Cells(Rw + 8, 4))
'Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If

' WH Overrides
Set KeyCells = Sheets("Line Flow").Range(Cells(Rw + 16, 4), Cells(Rw + 19, 4))
'Debug.Print (KeyCells.Address)
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
shtlf.Calculate
End If
Rw = Rw + 48
Next a

Application.EnableEvents = True
End Sub

Paul_Hossler
01-28-2019, 09:34 AM
I'm a little (lot) confused

Target is the cell or cells that changed, and I don't think you're making the most use of it

For example, below rowChangedSection is the starting row number of the block or 48 rows that make up each 'group' and rChangedSection it the range of that group (I guessed about the last column)



So you don't need to loop 400 times, just check out that one section

The structure I'm most familiar is the If Then / ElseIf …. below


Since it looks like a lot of this this to recalculate the sheet, why not just recalc anyway, or let Excel do it in Automatic?

Also (minor) in ...



Application.Intersect(KeyCells, Range(Target.Address))


Since Target is already a Range, you can get by with just



Application.Intersect(KeyCells, Target))





Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rChangedCell As Range, rChangedSection As Range
Dim rowChangedSection As Long ' first row of changed section
Dim shtLF As Worksheet, rngCal As Range, rngVal As Range
Dim pdat As Date, shtDates As Worksheet
Dim rngDate As Range, strDT As String, colLast As Long
Dim shtDT As Date


Set rChangedCell = Target.Cells(1, 1)
rowChangedSection = Int((rChangedCell.Row - 8) / 48) * 48 + 9

pdat = VBA.Format(Now(), "dd/mm/yyyy")
Set shtLF = ActiveWorkbook.Sheets("Line Flow")
Set shtDates = ActiveWorkbook.Sheets("Dates")
Set rngDate = shtDates.Range("A:A")
shtDT = rngDate.Find(pdat, , xlValues, xlWhole).Offset(, 2).Value
colLast = shtLF.Rows(6).Find(shtDT, , xlValues, xlWhole).Column

Set rChangedSection = shtLF.Cells(rowChangedSection, 1).Resize(48, colLast) ' <<< Not sure

' Allocation Row
If Not Intersect(rChangedSection.Rows(6), rChangedCell) Is Nothing Then
'...….. something

' Override Sales Row
ElseIf Not Intersect(rChangedSection.Rows(10), rChangedCell) Is Nothing Then

'...….. something

'Reschedule Rows
ElseIf Not Intersect(rChangedSection.Rows(17), rChangedCell) Is Nothing Then

'...….. something

ElseIf Not Intersect(rChangedSection.Rows(18), rChangedCell) Is Nothing Then

'...….. something


ElseIf Not Intersect(rChangedSection.Rows(21), rChangedCell) Is Nothing Then

'...….. something


ElseIf Not Intersect(rChangedSection.Rows(22), rChangedCell) Is Nothing Then

'...….. something


ElseIf Not Intersect(rChangedSection.Rows(25), rChangedCell) Is Nothing Then

'...….. something


ElseIf Not Intersect(rChangedSection.Rows(26), rChangedCell) Is Nothing Then

'...….. something


ElseIf Not Intersect(rChangedSection.Rows(29), rChangedCell) Is Nothing Then

'...….. something

ElseIf Not Intersect(rChangedSection.Rows(30), rChangedCell) Is Nothing Then

'...….. something


End If

Application.EnableEvents = True

End Sub