VBA to cut and paste or move data from the Master sheet when column D says "Completed" or "Deferred" to either the Completed or Deferred Worksheet

[Nathan20]

Hello everyone,

I'm in need of some assistance.
I want to have the data from each row to be cut and pasted or moved (whichever is easier) to the corresponding worksheet based on specific criteria.
When column D (Status) in the Master worksheet reads "Completed" I want it to automatically be cut and pasted or moved to the Completed worksheet. Likewise, if column D (Status) in the Master worksheet reads "Deferred" then it should go to the Deferred worksheet.

Thank you all so much in advance! I've been struggling with this for weeks and have just about given up on the idea.

 

[mumps]

I noticed that "Notes" is located in column G of the Master but in column H of the other two sheets. Is this correct? If so, what, if anything, goes in column G of the other two sheets?

 

[Nathan20]

I accidentally added an extra row in the Deferred and Completed worksheets before "Notes". I removed them to make both the Deferred and Completed worksheets the same as the Master worksheet. Great catch! Sorry about that. Thus, "Notes" is in column G. Thank you!

 

[Georgiboy]

Maybe something like:

Sub test()
    Dim mTbl As ListObject, dTbl As ListObject, cTbl As ListObject
    Dim NewRow As ListRow, fRng As Range
   
    Set mTbl = Sheets("Master").ListObjects(1)
    Set dTbl = Sheets("Deferred").ListObjects(1)
    Set cTbl = Sheets("Completed").ListObjects(1)
   
    Application.DisplayAlerts = False
   
    mTbl.Range.AutoFilter 3, "Completed"
    On Error Resume Next
        Set fRng = mTbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not fRng Is Nothing Then
        Set NewRow = cTbl.ListRows.Add
        fRng.Copy
        Sheets("Completed").Range("A" & NewRow.Index + 2).PasteSpecial xlValues
        mTbl.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
    End If
    Set fRng = Nothing
   
    mTbl.Range.AutoFilter 3, "Deferred"
    On Error Resume Next
        Set fRng = mTbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not fRng Is Nothing Then
        Set NewRow = dTbl.ListRows.Add
        fRng.Copy
        Sheets("Deferred").Range("A" & NewRow.Index + 2).PasteSpecial xlValues
        mTbl.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
    End If
   
    mTbl.Range.AutoFilter 3
   
    Application.DisplayAlerts = True
End Sub

 

[mumps]

Copy and paste this macro into the worksheet code module. Do the following: right click the tab name for your sheet and click 'View Code'. Paste the macro into the empty code window that opens up. Close the code window to return to your sheet. Enter a value in column D of the Master and press the ENTER key. Please note that the STATUS must be the last column completed in any row.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.CountLarge > 1 Then Exit Sub
    If Target.Column <> 4 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Select Case Target.Value
        Case "Completed"
            With Sheets("Completed")
                Range("B" & Target.Row).Resize(, 6).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                Range("B" & Target.Row).Resize(, 6).Delete shift:=xlUp
            End With
        Case "Deferred"
            With Sheets("Deferred")
                Range("B" & Target.Row).Resize(, 6).Copy .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
                Range("B" & Target.Row).Resize(, 6).Delete shift:=xlUp
            End With
    End Select
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[Nathan20]

IT WORKS @mumps & @Georgiboy! Thank you both so much! I really appreciate it!

 

[mumps]

You are very welcome.