Macro to move entire row if cell contains a specific word and moved to sheet 2

Astarte,

Welcome to the forum. Attached is a modified version of your workbook. I had to change a few things to get it all to work:

• Moved the validation list items into a new (hidden) worksheet named 'Lists'
• Set up named ranges for each of the validation lists so that they could be used in the other two worksheets
  • Note: The named range formula isn't necessary, I put it in there so you can add/remove items to the list and it will update automatically
• Removed the conditional formatting in the 'Active' worksheet
  • When items were cut/pasted between sheets, the conditional formatting got messed up and was causing "Overlap" errors.
  • In the code, I included a VBA version of conditional formatting so that the sheet would still the desired formatting effect. This prevented the "Overlap" errors.

Here's the code that I came up with (note, this is in the ThisWorkbook event module, not a Sheet event module):

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    
    If Sh.Name <> "Active" And Sh.Name <> "Archives" Then Exit Sub
    
    Application.EnableEvents = False
    Dim JCell As Range
    Dim FCell As Range
    Dim rngRows As Range
    
    On Error Resume Next
    Static rngJ As Range: Set rngJ = Intersect([J:J], Target)
    If Not rngJ Is Nothing Then
        
        Set rngRows = Nothing
        If Sh.Name = "Active" Then
            For Each JCell In rngJ
                If JCell.Value = Sheets("Lists").[E2].Value Then
                    If rngRows Is Nothing Then
                        Set rngRows = JCell
                    Else
                        Set rngRows = Union(rngRows, JCell)
                    End If
                End If
            Next JCell
            If Not rngRows Is Nothing Then
                rngRows.EntireRow.Copy Sheets("Archives").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                rngRows.EntireRow.Delete xlShiftUp
            End If
        Else
            For Each JCell In rngJ
                If JCell.Value <> Sheets("Lists").[E2].Value Then
                    If rngRows Is Nothing Then
                        Set rngRows = JCell
                    Else
                        Set rngRows = Union(rngRows, JCell)
                    End If
                End If
            Next JCell
            If Not rngRows Is Nothing Then
                rngRows.EntireRow.Copy Sheets("Active").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                rngRows.EntireRow.Delete xlShiftUp
            End If
        End If
        
    End If
    
    Static rngF As Range: Set rngF = Intersect([F:F], Target)
    If Not rngF Is Nothing Then
        
        Sh.UsedRange.Offset(1, 0).Interior.ColorIndex = 0
        Set rngRows = Nothing
        For Each FCell In rngF
            If FCell.Value = Sheets("Lists").[B2].Value Then
                If rngRows Is Nothing Then
                    Set rngRows = Sh.Range("A" & FCell.Row, "K" & FCell.Row)
                Else
                    Set rngRows = Union(rngRows, Sh.Range("A" & FCell.Row, "K" & FCell.Row))
                End If
            
            End If
        Next FCell
        If Not rngRows Is Nothing Then rngRows.Interior.ColorIndex = 3
        
    End If
    
    Application.EnableEvents = True
    
End Sub

Hope that helps,
~tigeravatar

Hi Tigeravatar,

Thank you so much it is really appreaciated.

Kind regards,

Astarte