CODEWITHSUNDEEP
excelvba
SMTH
SMTH

Reputation: 95

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

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:

enter image description here

Sheet1 after running the macro:

enter image description here

Sheet2 where the value should be placed like:

enter image description here

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?

Upvotes: 0

Views: 213

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

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..

Upvotes: 1

Related Questions