Using active cell move entire row from one table to another

[rorobear]

Hello Everyone,

Hoping someone can please assist with the below code. I have two tables on a sheet (Table1 and Table2). When a button on the sheet (called “Move Above”) is clicked, the entire row based on the active cell is supposed to move up the last row of the Table1 from Table2. The problem is the correct row where the active cell is not being moved. Instead, the row above the active cell it is moved. Please help me correct this, any assistance is greatly appreciated. The workbook is attached.


Option Explicit

Sub Move_AboveCutline()
' Macro to move the selected row from the Table to Table_1
Dim Tbl As ListObject
Dim NewRow As ListRow

Set Tbl = Range("Table1").ListObject
Set NewRow = Tbl.ListRows.Add(AlwaysInsert:=True)

If Not Intersect(ActiveCell, ActiveSheet.ListObjects("Table2").DataBodyRange) Is Nothing Then
Intersect(ActiveCell.EntireRow, Sheet1.ListObjects("Table2").DataBodyRange).Select
Else
MsgBox "You have not selected a row to move", vbInformation, "Move Row"
Exit Sub
End If

Selection.Cut

NewRow.Range = Selection.Value

'Delete the active cell's entire row
ActiveCell.EntireRow.Delete

Application.CutCopyMode = False

End Sub

[AC PORTA VIA]

try this

Sub Move_AboveCutline()' Macro to move the selected row from the Table to Table_1
Dim Tb1 As ListObject
Dim NewRow As ListRow

Set Tb1 = Range("Table1").ListObject


If Not Intersect(ActiveCell, ActiveSheet.ListObjects("Table2").DataBodyRange) Is Nothing Then
Intersect(ActiveCell.EntireRow, Sheet1.ListObjects("Table2").DataBodyRange).Select
Else
MsgBox "You have not selected a row to move", vbInformation, "Move Row"
Exit Sub
End If
Set NewRow = Tb1.ListRows.Add(AlwaysInsert:=True)
Selection.Offset(1).Cut

NewRow.Range = Selection.Offset(1).Value



Selection.Offset(1).Delete


End Sub

[rorobear]

worked like a charm. thank you kindly for the assist!!!

[AC PORTA VIA]

no problem, glad to help.