Cut a row from "sheet 1" and paste onto "sheet2", run-time error '1004' "Paste method of Worksheet class failed"

[csouth]

Good morning. I am new to vba and am having a little trouble understanding why I am receiving an error message. I have built a spreadsheet to track maintenance project in a facility. This spreadsheet will automatically change the value of the cells in column 'J' form "In Progress" to "Completed" when a value is inputted into the column 'G'. I had hoped to be able to write a macro that would check the value of column 'J', one row at a time, and if the value were "Completed" then it would cut that row, open sheet2, find the next empty row, paste the cut row, and delete the row it cut from sheet1. This macro will work perfectly one time. On the second time through, I will get "Run-time error 1004: Paste method of Worksheet class failed". Below is the code and a snip of the worksheet for reference. Any help would be greatly appreciated.

Sub MoveData()
Dim r1, r2
' Determine that last row in the Data Sheet (r1)
Sheets("MAINTENANCE TRACKER").Select
r1 = Range("J65536").End(xlUp).Row

Dim count As Long
For count = 1 To r1
If Range("J" & count).Value = "COMPLETED" Then
DoEvents
Sheets("MAINTENANCE TRACKER").Activate
Rows(count).Cut
Sheets("ARCHIVE COMPLETED").Activate
Sheets("ARCHIVE COMPLETED").Unprotect Password = "1234"
' Determine that last row in the ARCHIVE COMPLETED (r2)
r2 = Range("A65536").End(xlUp).Row
Rows(r2 + 1).Select
ActiveSheet.Paste
DoEvents
Sheets("ARCHIVE COMPLETED").Protect Password = "1234"
Sheets("MAINTENANCE TRACKER").Activate
Rows(count).EntireRow.Delete
count = 1
Application.CutCopyMode = False
End If
Next
End Sub

 

[rpaulson]

try this on a copy of your file.

Sub move_Complete()
Application.ScreenUpdating = False
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Counter = 0

Set ws1 = Worksheets("MAINTENANCE TRACKER")
Set ws2 = Worksheets("ARCHIVE COMPLETED")

ws2.Unprotect Password = "1234"

lr = ws1.Cells(Rows.Count, "J").End(xlUp).Row

For r = 2 To lr
    If ws1.Cells(r, "J") = "COMPLETED" Then
        r2 = ws2.Cells(Rows.Count, "J").End(xlUp).Row + 1
        Rows(r).Copy Destination:=ws2.Rows(r2)
        Counter = Counter + 1
    End If

Next r


On Error Resume Next
    With ws1.Range("J2:J" & lr)
        .Replace "COMPLETED", False, xlWhole
        .SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
    End With
On Error GoTo 0

ws2.Protect Password = "1234"
 Application.ScreenUpdating = True
MsgBox (Counter & " Rows Copied")
End Sub

hth,
Ross

 

[MountainFog]

Similar to Ross's but with only one loop

Option Explicit
Sub MoveData()
    Application.ScreenUpdating = False
    'Define  and Set ws variables
    Dim MT As Object
    Set MT = ThisWorkbook.Sheets("MAINTENANCE TRACKER")
    Dim AC As Object
    Set AC = ThisWorkbook.Sheets("ARCHIVE COMPLETED")
    'Find Last Row with Data
    Dim MTlr As Integer
    MTlr = MT.Cells(MT.Rows.count, "J").End(xlUp).Row
    Dim AClr As Integer
    
    AC.Unprotect Password:="1234"
    
    Dim i As Integer
    For i = 1 To MTlr
        If MT.Range("J" & i).Value = "COMPLETED" Then
            'Find Last row in AC with Data
            AClr = AC.Cells(AC.Rows.count, "J").End(xlUp).Row
            MT.Rows(i).Cut
            AC.Paste AC.Rows(AClr + 1)
            Application.CutCopyMode = False
            MT.Rows(i).Delete
            i = i - 1
            MTlr = MTlr - 1
        End If
    Next i
    AC.Protect Password:="1234"
    Application.ScreenUpdating = True
End Sub

 

[csouth]

Similar to Ross's but with only one loop

Option Explicit
Sub MoveData()
    Application.ScreenUpdating = False
    'Define  and Set ws variables
    Dim MT As Object
    Set MT = ThisWorkbook.Sheets("MAINTENANCE TRACKER")
    Dim AC As Object
    Set AC = ThisWorkbook.Sheets("ARCHIVE COMPLETED")
    'Find Last Row with Data
    Dim MTlr As Integer
    MTlr = MT.Cells(MT.Rows.count, "J").End(xlUp).Row
    Dim AClr As Integer
   
    AC.Unprotect Password:="1234"
   
    Dim i As Integer
    For i = 1 To MTlr
        If MT.Range("J" & i).Value = "COMPLETED" Then
            'Find Last row in AC with Data
            AClr = AC.Cells(AC.Rows.count, "J").End(xlUp).Row
            MT.Rows(i).Cut
            AC.Paste AC.Rows(AClr + 1)
            Application.CutCopyMode = False
            MT.Rows(i).Delete
            i = i - 1
            MTlr = MTlr - 1
        End If
    Next i
    AC.Protect Password:="1234"
    Application.ScreenUpdating = True
End Sub

Thank you!! this worked perfectly.

 

[jolivanes]

Change references where required.

Sub Or_So_Maybe()
    With Sheets("Sheet1").Cells(1).CurrentRegion
        .AutoFilter 10, "COMPLETED", xlFilterValues
        .Offset(1).Copy Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .Offset(1).SpecialCells(12).EntireRow.Delete
        .AutoFilter
    End With
End Sub

 

[rpaulson]

Jolivanes, very nice work!

 

[jolivanes]

Thank you for the positive comment Ross. Much appreciated.

 

[MountainFog]

On Error Resume Next
With ws1.Range("J2:J" & lr)
.Replace "COMPLETED", False, xlWhole
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
End With
On Error GoTo 0

Ross, how does this section of your code work? Particularly Replace

 

[rpaulson]

it looks at the range ex. J2:J100, if the test string "COMPLETED" appears in an cell of the range, then it deletes the entire row.

example. if "COMPLETED" was in cell J5 and J17 then it would delete row 5 and row 17.

 

[MountainFog]

it looks at the range ex. J2:J100, if the test string "COMPLETED" appears in an cell of the range, then it deletes the entire row.

example. if "COMPLETED" was in cell J5 and J17 then it would delete row 5 and row 17.

How is replace being used? And why do you need to temporarily enable On Error Resume Next