Move row to sheets based on condition

[woodsey1982]

I'm having trouble with a macro to move rows from one worksheet to another based on a cell value.

I have a row with 4 headings. The final of these 4 columns will have one of three outcomes, CHANGE, NOTCHANGED or blank.

If the row is blank, the script should ignore and check the next row.

If the row says CHANGE then move to Sheet2 and delete the row from Sheet1.
If the row says NOTCHANGED then move to Sheet3 and delete the row from Sheet1.

Any script I have tried has deleted rows from above ( i.e the headings ) rather than start from row 5 where the information begins.

Any help much appreciated. I can post a sample if required.

 

[Trebor76]

Hi woodsey1982,

Try this, though initially on a copy of your data as the results cannot be undone if they're not as expected (or you could save the workbook first, run the macro and then close it without saving the changes if the results are incorrect):

Option Explicit
Sub Macro1()

    'https://www.mrexcel.com/forum/excel-questions/1004992-move-row-sheets-based-condition.html

    Dim i          As Integer
    Dim lngLastRow As Long
    
    Application.ScreenUpdating = False
    
    lngLastRow = Sheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row
    
    Sheets("Sheet1").AutoFilterMode = False  'Remove any existing filters
    
    For i = 1 To 2
        With Sheets("Sheet1")
            If i = 1 Then
                With .Range("D4:D" & lngLastRow)
                    .AutoFilter Field:=1, Criteria1:="CHANGE"
                    With .Offset(1).SpecialCells(xlCellTypeVisible) 'Offset(1) as it's assumed first row is the header row
                        .Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1) 'Copies the data to the next available row in Col. A of Sheet2. Change to suit.
                        Application.DisplayAlerts = False
                            .Rows.Delete
                        Application.DisplayAlerts = True
                    End With
                End With
            Else
                 With .Range("D4:D" & lngLastRow)
                    .AutoFilter Field:=1, Criteria1:="NOTCHANGED"
                    With .Offset(1).SpecialCells(xlCellTypeVisible) 'Offset(1) as it's assumed first row is the header row
                        .Copy Destination:=Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1) 'Copies the data to the next available row in Col. A of Sheet3. Change to suit.
                        Application.DisplayAlerts = False
                            .Rows.Delete
                        Application.DisplayAlerts = True
                    End With
                End With
            End If
        End With
    Next i
    
    'Remove existing filter
    Sheets("Sheet1").AutoFilterMode = False
        
    Application.ScreenUpdating = True
    
    MsgBox "All applicable rows have now been moved.", vbInformation
    
End Sub

Regards,

Robert