Cut the row from a sheet and paste it to another if certain criteria is met

Question

Hi I am trying to create a macro which cuts the selected row if it matches a certain criteria and has to paste it to a different sheet from the same workbook. Could Some please help me?

Answer 1

This should work to show you how to delete a row based on a condition and put it in another sheet. You didn't specify conditions and constraints so I just made some up to have a working algorithm you'd be able to adapt from. Put it in a new workbook; I inserted some instructions to include a breakpoint in the code so you can see what the program does at runtime.

Sub ConditionalRowCutPaste()

'adds 2 sheets and puts numbers 1-50 in the first column
'if you run this multiple times, delete these sheets before executing again
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "SheetB"

Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "SheetA"

For i = 1 To 50
    Cells(i, 1).Value = i
Next i

i = 0

' this is where the row cut and paste begins; add a breakpoint
' (click on the gray line to the left of Do, it'll add a red dot)
' then press F8 to see how the algorithm plays along

Do


    Sheets("SheetA").Select
    i = i + 1

    If Cells(i, 1).Value = "" Then Exit Do

    'this is the condition to cut and paste row, here it tests
    'if the number in column 1 is even; may be your condition is in a different
    'cell and has a different criteria

    If Cells(i, 1).Value Mod 2 = 0 Then

        Rows(i).Cut
        Sheets("SheetB").Select
        j = 0

        Do

            'it loops until it finds an empty cell in the first column;
            'your criteria for where to put the row might be different
            j = j + 1

            If Cells(j, 1).Value = "" Then
                Rows(j).Select
                ActiveSheet.Paste
                Exit Do
            End If

        Loop

        'after the row is copied to the new sheet, it's deleted from the
        'original sheet
        Sheets("SheetA").Select
        Rows(i).Select
        Selection.Delete Shift:=xlUp
        i = i - 1

    End If


Loop


End Sub

Let me know how this works for you.

Best.