VBA Code Fix for Moving row from one table to another based on criteria

Question

*Edit - I added the text code for my second attempt and updated the worksheet rows based on BlackCat's recommendation. Still, it is adding the row to the end after my table instead of in my table. Here's a link to my excel spreadsheet

I am wanting to move rows automatically using VBA code from one table to another table in another tab in my excel workbook.

My first tab is called "Current Projects" with a 4th column called "Status". This table has about 21 columns and is updated regularily. When I select the status as "Completed" or "Cancelled", I would like the VBA code to immediately run and essentially "cut" that row and copy it in its entirety (all 21 columns of information for that tow) to another tab called "Archive" using the next empty row in that existing table (so it does not overwrite any existing data already in the table).

I am very new to VBA coding and have tried the two following options I found on the internet but both have given errors or not done what I need. I think it may be also my fault for not knowing how to plug in my information into the codes I am finding on the internet so any explanations on that would also be nice to know so I can learn what I did wrong.

Any help that can be provided would be greatly appreciated!

First Try: In Sheet Code - enter image description here This didn't work, I think because of something in the highlighted portion and gave a subscript out of range error

Second Try: 2 Modules Created: Module 1

Sub MoveBased2OnValue()

    Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long

    A = Worksheets("Current Projects").Range("D" & Worksheets("Current Projects").Rows.Count).End(xlUp).Row
    B = Worksheets("Archive").Range("D" & Worksheets("Current Projects").Rows.Count).End(xlUp).Row
    If B = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then B = 0
    End If
    Set xRg = Worksheets("Current Projects").Range("D1:D" & A)
    On Error Resume Next
    Application.ScreenUpdating = False
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = "Completed" Then
            Set rowx = Worksheets("Archive").AutoFilter.Range
            rowx.AutoFilter
            xRg(C).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & B + 1)
            rowx.AutoFilter
            xRg(C).EntireRow.Delete
            If CStr(xRg(C).Value) = "Completed" Then
                C = C - 1
            End If
            B = B + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Module 2

   Sub MoveBasedOnValue()
    Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("Current Projects").Range("D" & Worksheets("Current Projects").Rows.Count).End(xlUp).Row
    B = Worksheets("Archive").Range("D" & Worksheets("Current Projects").Rows.Count).End(xlUp).Row
    If B = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Archive").UsedRange) = 0 Then B = 0
    End If
    Set xRg = Worksheets("Current Projects").Range("D1:D" & A)
    On Error Resume Next
    Application.ScreenUpdating = False
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = "Cancelled" Then
            Set rowx = Worksheets("Archive").AutoFilter.Range
            rowx.AutoFilter
            xRg(C).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & B + 1)
            rowx.AutoFilter
            xRg(C).EntireRow.Delete
            If CStr(xRg(C).Value) = "Cancelled" Then
                C = C - 1
            End If
            B = B + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

And a Sheet Code

    Sub SheetCode()
        Dim Z As Long
        Dim xVal As String
        On Error Resume Next
        If Intersect(Target, Range("D:D")) Is Nothing Then Exit Sub
        Application.EnableEvents = False
        For Z = 1 To Target.Count
            If Target(Z).Value > 0 Then
                Call MoveBasedOnValue
                Call MoveBased2OnValue
            End If
        Next
        Application.EnableEvents = True
    End Sub

This did all the necessary stuff (cut the row when I selected Completed or Cancelled and added it to the Archive tab) BUT it would add the row at the end of the table and not to the existing table which I need it to do as I have some other formulas already in the worksheet that rely on the data being in a table format

Answer 1

The issue can be that in the code of the Second Try the determining of the last filled row is defined with UsedRange property. But this property can return sometimes false value because of the (e.g.) previous data formatting of the cells on the sheet. To get the correct row or column index of the last used cell

• search only the column or row which need
• use the End property

something like this

Range("F" & Rows.Count).End(xlUp).Row            'last occupied row in column=F
Cells(4, Columns.Count).End(xlToLeft).Column     'last occupied column in row=4

After edit the question. In both Sub insert instead

A = Worksheets("Current Projects").UsedRange.Rows.Count
B = Worksheets("Archive").UsedRange.Rows.Count

this

A = Worksheets("Current Projects").Range("D" & Worksheets("Current Projects").Rows.Count).End(xlUp).Row
B = Worksheets("Archive").Range("D" & Worksheets("Current Projects").Rows.Count).End(xlUp).Row

and instead

Set rowx = Worksheets("Archive").AutoFilter.Range
        rowx.AutoFilter
        xRg(C).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & B + 1)
        rowx.AutoFilter

this

Worksheets("Archive").ListObjects(1).ListRows.Add
xRg(C).EntireRow.Copy Destination:=Worksheets("Archive").Range("A" & B + 1)

Answer 2

update, converted back into change event with adding copied row to table "tblArchive"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wsCurrent As Worksheet
    Dim wsArchive As Worksheet
    Dim tblArchive As ListObject
    Dim newRow As ListRow
    Dim i As Long
    
    ' Set the worksheets to the respective sheets
    Set wsCurrent = ThisWorkbook.Worksheets("Current Projects")
    Set wsArchive = ThisWorkbook.Worksheets("Archive")
    
    ' Check if the change occurred in column D of the "Current Projects" sheet
    If Not Intersect(Target, wsCurrent.Columns("D")) Is Nothing Then
        Application.EnableEvents = False ' Disable events to prevent triggering the event again
        
        ' Set the tblArchive as the "tblArchive" table in the "Archive" sheet
        Set tblArchive = wsArchive.ListObjects("tblArchive")
        
        ' Loop through the changed cells in column D
        For Each cell In Target
            ' Check if the cell value is "Completed" or "Cancelled"
            If cell.Value = "Completed" Or cell.Value = "Cancelled" Then
                ' Insert a new row at the end of the tblArchive table
                Set newRow = tblArchive.ListRows.Add
                
                ' Copy specific columns (A to AJ) and paste values into the new row of the tblArchive table
                wsCurrent.Range("A" & cell.Row & ":AJ" & cell.Row).Copy
                newRow.Range.PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False ' Clear the clipboard
                wsCurrent.Rows(cell.Row).Delete ' Delete the row from the "Current Projects" sheet
            End If
        Next cell
        
        Application.EnableEvents = True ' Enable events back
    End If
End Sub