Stopping muliple triggers through Worksheet_Change(ByVal Target As Range)

[nl05369]

Hello expoerts,

I have a sheet whereby when 1 cell in column T is filled with a valid date, then that row in the sheet will be moved to a different sheet.
Problem is: when I perform the cut/paste, that is also seen as an alteration to the column T, starts subroutine of the cell change, and the routine fails.
How do I, if the routine for change in the date cell in column T is already active, not have it trigger again?

VBA below:

Private Sub Worksheet_Change(ByVal Target As Range)

' This routine will move a line from active to afgewerkt if call in column U is filled with valid date.
' Otherwise, the value in the cell will be erased.

Dim Date_Check As Boolean
Dim dt As String
Dim Answer As String
Dim Changed_Cell As String

On Error GoTo MyErrorHandler:

' Set variable Changed_Cell to address of cell that
Changed_Cell = Target.Address
Cell_Value = Intersect(Target, Range("T3:T999"))
Sheets("Current").Range(Changed_Cell).Select

If Not Intersect(Target, Range("T3:T999")) Is Nothing Then GoTo Perform_Action
GoTo Skip

Perform_Action:
' Check that content of changed cell is not empty or space
If Cell_Value = "" Or Cell_Value = " " Then GoTo Skip

' Verify that entry is a valid date and nothin else.
Date_Check = IsDate(Cell_Value)

If Date_Check = "False" Then GoTo Clear_Contents   ' do nothing if the data is not a valid date
If Date_Check = "True" Then Answer = MsgBox("Do you want to move this line", vbYesNo + vbQuestion, "Move Line")
If Answer = 6 Then Call MoveLine
If Answer = 7 Then GoTo Clear_Contents

GoTo Skip


Clear_Contents:
Range(Changed_Cell).Select
ActiveCell = ""

Skip:

' to avoid the message on closing the book - "picture is too large and will be truncated", copy and paste a singe empty cell
ThisWorkbook.Worksheets(1).Cells(1, 1).Copy
ThisWorkbook.Worksheets(1).Cells(1, 1).PasteSpecial xlValues

' clear clipboard
Application.CutCopyMode = False

Exit Sub
MyErrorHandler:
If Err.Number = 1004 Then
  ActiveCell(1, -1) = "Not Found"
  'MsgBox "Not Found"
 ' ActiveCell.Offset(1, 0).Select
ElseIf Err.Number = 13 Then
'  MsgBox "You have entered an invalid value."
End If

End Sub

Sub MoveLine()
Move_Line:
    ActiveCell.Rows("1:1").EntireRow.Select
    
    Selection.Cut
    Sheets("Afgewerkt").Select
    
    ActiveCell.SpecialCells(xlLastCell).Select
    
    ActiveCell.Rows("1:1").EntireRow.Select
    Selection.Insert Shift:=xlDown
    
    ActiveSheet.Previous.Select
    
    Selection.Delete Shift:=xlUp
    
    Sheets("Current").Range("C" & (ActiveCell.Row)).Select

End Sub

 

[RoryA]

Use:

Application.EnableEvents = False

before you make any changes in the Change event, then make sure to reset back to True when the procedure is done.

 

[nl05369]

Use:

Application.EnableEvents = False

before you make any changes in the Change event, then make sure to reset back to True when the procedure is done.

Rory... you de man!
Excelent, and simple.
Thank you very much.

 

[RoryA]

Glad to help.