How to speed up a Change Event Loop

[Poundland]

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]

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