Macro - Cut and Paste Row

Question

I am trying to get a macro that will cut and paste certain rows from one sheet (TM) if the value in column G is changed to "Closed" it will then cut and paste the data to the second sheet (TMC).

Please could someone point me in the right direction?

Many Thanks

Answer 1

Hi

My other post will copy and transfer to the other sheet.

This one will cut and paste to the other sheet also delete the empty rows.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim sh2    As Worksheet

    Dim sh1    As Worksheet

    Dim finalrow As Long

    Dim lastrow As Long

    Dim i      As Long, val as long

    Set sh1 = Sheets("TM")

    Set sh2 = Sheets("TMC")

    Application.EnableEvents = False

    finalrow = sh1.Cells(Rows.Count, 1).End(xlUp).Row

    If Not Intersect(Target, Range("G:G")) Is Nothing Then

        If UCase(Target.Value) = "CLOSED" Then

        val = Target.Row

            lastrow = sh2.Cells(Cells.Rows.Count, 1).End(xlUp).Row

            sh1.Cells(Target.Row, 1).EntireRow.Cut Destination:=sh2.Cells(lastrow + 1, 1)

            sh1.Cells(val, 1).EntireRow.Delete

        End If

   End If

   Application.EnableEvents = True

End Sub

Answer 2

HI

This is an event macro, it will run every time you type Closed in column G.

On your Worksheet Tab, right click and select "View Code". Or press Alt+F11, it will do the same.

That will take you to the VB Editor.

Now paste the macro on that page.

Press Alt+Q to return to your worksheet.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim sh2    As Worksheet

    Dim sh1    As Worksheet

    Dim finalrow As Long

    Dim lastrow As Long

    Dim i      As Long

    Set sh1 = Sheets("TM")

    Set sh2 = Sheets("TMC")

    Application.EnableEvents = False

    finalrow = sh1.Cells(Rows.Count, 1).End(xlUp).Row

    If Not Intersect(Target, Range("G:G")) Is Nothing Then

        If UCase(Target.Value) = "CLOSED" Then

            lastrow = sh2.Cells(Cells.Rows.Count, 1).End(xlUp).Row

            Cells(Target.Row, 1).EntireRow.Copy Destination:=sh2.Cells(lastrow + 1, 1)

        End If

   End If

   Application.EnableEvents = True

End Sub