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
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