Numerous events sheetchane not working

[I3atnumb3rs]

Hi,

Checked a bunch of threads and am not able to get more than one intersect statement to run in my workbook. Each statement runs perfectly as seperate statements. I want an entire row to be move to a tab of the same status name when a dropdown status is chosen on any sheet and I want the entire row copied when a date is entered in another column on any sheet to the returns tab. Help svp!



Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False

If Intersect(Target, Range("S:S")) Is Nothing Then Exit Sub
On Error GoTo errhandler

If Target = "SCHEDULED" Then
Target.EntireRow.Copy Sheets("SCHEDULED").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Target.EntireRow.Delete

ElseIf Target = "COMPLETED" Then
Target.EntireRow.Copy Sheets("COMPLETED").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Target.EntireRow.Delete

ElseIf Target = "CANCELLED" Then
Target.EntireRow.Copy Sheets("CANCELLED").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Target.EntireRow.Delete
ElseIf Target = "NOT SHIPPED" Then
Target.EntireRow.Copy Sheets("ACTION").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Target.EntireRow.Delete

End If

If Not Intersect(Target, Range("Q:Q")) Is Nothing Then
If Selection.Count > 1 Then Exit Sub
Dim Lastrow As Long
Lastrow = Sheets(5).Cells(Rows.Count, "A").End(xlUp).Row + 1
If IsDate(Target.Value) Then Rows(Target.Row).Copy Destination:=Sheets(5).Rows(Lastrow)
End If

Application.ScreenUpdating = True
errhandler:
Application.EnableEvents = True





End Sub

 

[Fluff]

Try

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False

If Intersect(Target, Range("S:S")) Is Nothing Then
   On Error GoTo errhandler
   
   If Target = "SCHEDULED" Then
      Target.EntireRow.Copy Sheets("SCHEDULED").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
      Target.EntireRow.Delete
   
   ElseIf Target = "COMPLETED" Then
      Target.EntireRow.Copy Sheets("COMPLETED").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
      Target.EntireRow.Delete
   
   ElseIf Target = "CANCELLED" Then
      Target.EntireRow.Copy Sheets("CANCELLED").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
      Target.EntireRow.Delete
   ElseIf Target = "NOT SHIPPED" Then
      Target.EntireRow.Copy Sheets("ACTION").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
      Target.EntireRow.Delete
   End If

ElseIf Not Intersect(Target, Range("Q:Q")) Is Nothing Then
   If Selection.Count > 1 Then Exit Sub
   Dim Lastrow As Long
   Lastrow = Sheets(5).Cells(Rows.Count, "A").End(xlUp).Row + 1
   If IsDate(Target.Value) Then Rows(Target.Row).Copy Destination:=Sheets(5).Rows(Lastrow)
End If

Application.ScreenUpdating = True
errhandler:
Application.EnableEvents = True
End Sub

 

[I3atnumb3rs]

Tried it, but it doesn't work

 

[I3atnumb3rs]

It seems that any time I make any change to any cell in the workbook the sub stops working entirely. Any idea why?

 

[DanteAmor]

But this Workbook_SheetChange event works on every page of your book.


If you want it to work only on a specific sheet you should put this Worksheet_Change event, but on the specific sheet where you capture data.

Target.EntireRow.Copy Sheets("SCHEDULED").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Target.EntireRow.Delete

You copy the row, but the event is reactivated and the copied row is deleted.

I guess you want to capture the data in a summary sheet and send this data to a different sheet, right?

 

[Fluff]

Just noticed that you need to make this change

ElseIf Not Intersect(Target, Range("Q:Q")) Is Nothing Then
   If Selection.Count > 1 Then [COLOR=#ff0000]Goto errhandler[/COLOR]
   Dim Lastrow As Long
   Lastrow = Sheets(5).Cells(Rows.Count, "A").End(xlUp).Row + 1
   If IsDate(Target.Value) Then Rows(Target.Row).Copy Destination:=Sheets(5).Rows(Lastrow)
End If

Can you please explain what "Stops working" means?

 

[I3atnumb3rs]

Still not running even with the change.When I only have 1 sub and I open the sheet, any time I change the drop down the row moves perfectly like it's supposed to, but if I make any change to any tab in the workbook the sub will no longer execute.

 

[DanteAmor]

Try this:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    If Target.Count > 1 Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    On Error GoTo errhandler
    
    If Not Intersect(Target, Range("S:S")) Is Nothing Then
        Dim ws As String
        Select Case Target.Value
            Case "SCHEDULED": ws = "SCHEDULED"
            Case "COMPLETED": ws = "COMPLETED"
            Case "CANCELLED": ws = "CANCELLED"
            Case "NOT SHIPPED": ws = "ACTION"
            Case Else: ws = ""
        End Select
        If ws <> "" Then
            Target.EntireRow.Copy Sheets(ws).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            Target.EntireRow.Delete
        End If
    End If
    If Not Intersect(Target, Range("Q:Q")) Is Nothing Then
        Dim Lastrow As Long
        Lastrow = Sheets(5).Cells(Rows.Count, "A").End(xlUp).Row + 1
        If IsDate(Target.Value) Then Rows(Target.Row).Copy Destination:=Sheets(5).Rows(Lastrow)
    End If
    
    Application.ScreenUpdating = True
errhandler:
    Application.EnableEvents = True


End Sub

 

[I3atnumb3rs]

YES! it works perfectly you are amazing thank you!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.