CODEWITHSUNDEEP
excelvba
user3840770
user3840770

Reputation: 1

Conditional Cut and Paste a selected row to a different sheet

I have the following formula that searches for rows with the text 'Completed' in collumn C on 'Live and pipeline'sheet. if that condition is met, cut and paste the whole row to the 'Completed' Sheet in the same workbook. There should be no empty rows in Sheet1 after this procedure.

At the moment I am getting Application Run time error 1004, Application defined or object defined error on line Selection.Cut Shift:=xlUp. The whole code is in Module1. Can anyone tell me what's gone wrong here?

Sub Completed_Projects()
'
' Move completed projects to the Completed Tab
'
'   Search until an empty cell is reached
Dim Row As Integer
Row = Range("Total_Completed").Row
Dim SumRow As Integer

Application.ScreenUpdating = False
For Each Cell In ActiveSheet.Range("C8:C100").Cells
    If Cell.Value = "Completed" Or Cell.Value = "Aborted" Then
       Rows(Cell.Row).Select
       Selection.Cut Shift:=xlUp

       ' Paste Selection
       Reference = "A" & Row
       Application.Goto (ActiveWorkbook.Sheets("Completed").Range(Reference))
       Range(Reference).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
       ActiveSheet.Paste

       ' Update Counters and go back to Live sheet
       Sheets("Live and pipeline").Select
       Row = Row + 1
    End If
Next Cell
       Application.ScreenUpdating = True 
'
End Sub

Upvotes: 0

Views: 4973

Answers (1)

Alex P
Alex P

Reputation: 12489

How about this? I've cleaned your code up a bit.

Sub Completed_Projects()
    Dim rw As Integer, counter As Integer

    counter = Range("Total_Completed").Row

    Application.ScreenUpdating = False
        For rw = 100 To 8 Step -1
            If Worksheets("Live and Pipeline").Range("C" & rw) = "Completed" Or Worksheets("Live and Pipeline").Range("C" & rw) = "Aborted" Then
                Rows(rw).Copy Destination:=Worksheets("Completed").Range("A" & counter)
                Rows(rw).EntireRow.Delete Shift:=xlUp
                counter = counter + 1
            End If
        Next rw
    Application.ScreenUpdating = True
End Sub

Upvotes: 1

Related Questions