Worksheet_Change More than 1on the same tab

[wlbamc]

Hi

I have 2 VBA codes, one to stop copy and paste over validated cells and the other to move a line to another tab when picked from dropdown list, is there any way of having them on the same tab

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xValue As String
    Dim xCheck1 As String
    Dim xCheck2 As String
    If Target.Count > 1 Then
        Exit Sub
        End If
        Application.EnableEvents = False
        xValue = Target.Value
        On Error Resume Next
        xCheck1 = Target.Validation.InCellDropdown
        On Error GoTo 0
        Application.Undo
        On Error Resume Next
        xCheck2 = Target.Validation.InCellDropdown
        On Error GoTo 0
        If xCheck1 = xCheck2 Then
            Target = xValue
        Else
            MsgBox "No pasting allowed!"
        End If
        Application.EnableEvents = True
    End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.ScreenUpdating = False
    If Intersect(Target, Range("AJ:AJ")) Is Nothing Then Exit Sub
    On Error GoTo endit
    Application.EnableEvents = False
    If Target.Value = "Deceased" Then
        Target.EntireRow.Copy Worksheets("Deceased").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Stopped Funding" Then
        Target.EntireRow.Copy Worksheets("No Longer Funded").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Change of Care Package" Then
        Target.EntireRow.Copy Worksheets("Change of Care Package").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
End If
endit:
     Application.EnableEvents = True
     Application.ScreenUpdating = True

Many thanks

 

[offthelip]

try this:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xValue As String
    Dim xCheck1 As String
    Dim xCheck2 As String
    If Target.Count = 1 Then
        Application.EnableEvents = False
        xValue = Target.Value
        On Error Resume Next
        xCheck1 = Target.Validation.InCellDropdown
        On Error GoTo 0
        Application.Undo
        On Error Resume Next
        xCheck2 = Target.Validation.InCellDropdown
        On Error GoTo 0
        If xCheck1 = xCheck2 Then
            Target = xValue
        Else
            MsgBox "No pasting allowed!"
        End If
        Application.EnableEvents = True
    End If
    If Intersect(Target, Range("AJ:AJ")) Is Nothing Then Exit Sub
    On Error GoTo endit
    Application.ScreenUpdating = False  'moved to prevent exiting sub with screenupdating turned off
    Application.EnableEvents = False
    If Target.Value = "Deceased" Then
        Target.EntireRow.Copy Worksheets("Deceased").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Stopped Funding" Then
        Target.EntireRow.Copy Worksheets("No Longer Funded").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Change of Care Package" Then
        Target.EntireRow.Copy Worksheets("Change of Care Package").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
End If
endit:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
    
    End Sub

 

[wlbamc]

T

try this:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xValue As String
    Dim xCheck1 As String
    Dim xCheck2 As String
    If Target.Count = 1 Then
        Application.EnableEvents = False
        xValue = Target.Value
        On Error Resume Next
        xCheck1 = Target.Validation.InCellDropdown
        On Error GoTo 0
        Application.Undo
        On Error Resume Next
        xCheck2 = Target.Validation.InCellDropdown
        On Error GoTo 0
        If xCheck1 = xCheck2 Then
            Target = xValue
        Else
            MsgBox "No pasting allowed!"
        End If
        Application.EnableEvents = True
    End If
    If Intersect(Target, Range("AJ:AJ")) Is Nothing Then Exit Sub
    On Error GoTo endit
    Application.ScreenUpdating = False  'moved to prevent exiting sub with screenupdating turned off
    Application.EnableEvents = False
    If Target.Value = "Deceased" Then
        Target.EntireRow.Copy Worksheets("Deceased").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Stopped Funding" Then
        Target.EntireRow.Copy Worksheets("No Longer Funded").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
    ElseIf Target.Value = "Change of Care Package" Then
        Target.EntireRow.Copy Worksheets("Change of Care Package").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete
End If
endit:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
   
    End Sub

That works perfectly, thank you so much