Help With VBA to Move one Row on one Table to Another Table

[Mista_sav]

I have identical Tables, one is called Active and one is called Completed. They are on separate Sheets, also called Active and Completed.

In column H there is an option to select the status. When someone selects "Complete - No Further Action Required" i would like it to move (then delete) this row from the table and add it to the Completed table.

Any help on a VBA to do this automatically?

 

[kevin9999]

Could you provide a small sample of your Active and Completed sheets using the XL2BB add in?

 

[Mista_sav]

Could you provide a small sample of your Active and Completed sheets using the XL2BB add in?

I dont sorry mate i have this snapshot though

 

[kevin9999]

And the Completed sheet?

 

[kevin9999]

I'll assume your Completed sheet has the exact same columns as your Active sheet. Try the following on a copy of your data.

Option Explicit
Sub Active_to_Completed()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Active")
    Set ws2 = Worksheets("Completed")
    
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 8, "Complete - No Further Action Required"
        If ws1.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Range("A" & ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            .Offset(1).EntireRow.Delete
        End If
        With ws1
            .ShowAllData
        End With
    End With
End Sub

 

[Mista_sav]

I'll assume your Completed sheet has the exact same columns as your Active sheet. Try the following on a copy of your data.

Option Explicit
Sub Active_to_Completed()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Active")
    Set ws2 = Worksheets("Completed")
   
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 8, "Complete - No Further Action Required"
        If ws1.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Range("A" & ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1)
            .Offset(1).EntireRow.Delete
        End If
        With ws1
            .ShowAllData
        End With
    End With
End Sub

This works mate. Just 2 things. It only works when i press run within the view code part. Also, it puts the data at the bottom of the completed table, can this go up top if possible?

 

[kevin9999]

I could make it so it runs automatically whenever there's a change in the H column - but is that what you really want? What if someone selects "Complete - No Further Action Required" by mistake? You'd be left with the annoyance of having to remove it from the Completed sheet & returning it to the Active sheet. I'll do that if that's what you want.

 

[kevin9999]

This first code inserts the moved row to row 2 of the Completed sheet..

Option Explicit
Sub Active_to_Completed_V2()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Active")
    Set ws2 = Worksheets("Completed")
    
    With ws1.Range("A1").CurrentRegion
        .AutoFilter 8, "Complete - No Further Action Required"
        If ws1.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).Copy
                ws2.Range("A2").Insert xlShiftDown
                Application.CutCopyMode = False
            .Offset(1).EntireRow.Delete
        End If
        With ws1
            .ShowAllData
        End With
    End With
End Sub

This second code does the move/delete automatically when there is a change in column H of the Active sheet. Obviously, this code goes in the sheet code area of the Active sheet & not in a standard module.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.CountLarge = 1 And Not Intersect(Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row), Target) Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        Dim ws1 As Worksheet, ws2 As Worksheet
        Set ws1 = Worksheets("Active")
        Set ws2 = Worksheets("Completed")
        
        With ws1.Range("A1").CurrentRegion
            .AutoFilter 8, "Complete - No Further Action Required"
            If ws1.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
                .Offset(1).Resize(.Rows.Count - 1).Copy
                ws2.Range("A2").Insert xlShiftDown
                Application.CutCopyMode = False
                .Offset(1).EntireRow.Delete
            End If
            With ws1
                .ShowAllData
            End With
        End With
    End If
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
End Sub

 

[Mista_sav]

Chefs Kiss...works perfectly thanks mate. It isnt a biggy as this shouldnt be used too much and can easily be fixed up.

Thanks again mate!

 

[kevin9999]

Chefs Kiss...works perfectly thanks mate. It isnt a biggy as this shouldnt be used too much and can easily be fixed up.

Thanks again mate!

Happy to help, and thanks for the feedback