Cut and delete an entire row but paste only the value of a row falling under specific column - excel

Question

I'm trying to cut and delete some entire rows having move it in ID column and paste only the value of that ID to another sheet using a macro. What I've written so far can cut and delete the rows but paste the whole row in another sheet instead of only the IDs.
Sheet1 before running the macro:
Sheet1 after running the macro:
Sheet2 where the value should be placed like:
My following attempt can do the second step flawlessly but when it comes to paste only the value of kicked out IDs in another sheet, it pastes the whole row.
Sub CutAndPaste()
Dim cel As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim wsAno As Worksheet: Set wsAno = ThisWorkbook.Sheets("Sheet2")
For Each cel In Range("C2:C10")
If cel(1, 1) = "move it" Then
ws.Range(cel(1, 1).Address).EntireRow.Cut wsAno.Range("A" & wsAno.Rows.count).End(xlUp).Offset(1, 0)
ws.Range(cel(1, 1).Address).EntireRow.Delete
wsAno.Range("B" & wsAno.Rows.count).End(xlUp).Offset(1, 0).Value = "done"
End If
Next cel
End Sub
How can I cut and delete an entire row but paste only the value of a row falling under ID column in another sheet?

Answer 1

Please, try the next code. It should be very fast, using an array for the ranges to be copied (cut if you like it better...) and deletion is done at once:
Sub CutAndPaste_()
Dim cel As range, rngDel As range, arrCut, lastRAn As Long, k As Long
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim wsAno As Worksheet: Set wsAno = ThisWorkbook.Sheets("Sheet2")
ReDim arrCut(1 To 2, 1 To 9) 'redim the array at a maximum able to keep all the necessary elements (10 -1)
For Each cel In ws.range("C2:C10")
If cel(1, 1).Value = "move it" Then
If rngDel Is Nothing Then 'if range to be deleted does not exist, yet:
k = k + 1
arrCut(1, k) = cel: arrCut(2, k) = "done" 'or cel.Offset(0, 1)
Set rngDel = cel
Else
k = k + 1
arrCut(1, k) = cel: arrCut(2, k) = "done" 'or cel.Offset(0, 1)
Set rngDel = Union(rngDel, cel)
End If
End If
Next cel
lastRAn = wsAno.range("A" & rows.count).End(xlUp).row + 1 'last empty row
ReDim Preserve arrCut(1 To 2, 1 To k) 'keep only the existing filled array elements
wsAno.range("A" & lastRAn).Resize(k, 2).Value = WorksheetFunction.Transpose(arrCut) 'drop the array value at once
rngDel.EntireRow.Delete xlUp 'delete the necessary rows at once
End Sub
I would suggest you to also use a variable to determine the last row in C:C and use it to create the range and also preliminary ReDim the array. It is filled with columns instead of rows, because only the last dimension can be ReDim Preserved..