Copy and paste row from one sheet to another in Excel - excel

Question

I am trying to set up an archiving system whereby when a user selects "Yes" from a column dropdown and click an 'Archive' button, all entries that have been selected to be archived will be moved to another sheet. The problem I am facing however is each time an entry is archived, it just overwrites the previous entry that was archived so there is only ever 1 row on the archive sheet. This is the code I am currently working with
Sub Archive_Yes()
Dim MatchRow As Long, FirstRow As Long, LastRow As Long
Dim Destination As Range
Dim ws As Worksheet
Dim i As Long
Set ws = Sheets("Sales Order Log")
FirstRow = 14
LastRow = ws.Cells(ws.Rows.Count, "AA").End(xlUp).Row
i = FirstRow
Do While i <= LastRow
If ws.Range("AA" & i).Value = "Yes" Then
MatchRow = ws.Range("Z" & i).Row
With Sheets("Archive")
Set Destination = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
ws.Range("A" & MatchRow & ":Z" & MatchRow).Copy Destination
ws.Rows(MatchRow).Delete Shift = xlUp
LastRow = LastRow - 1
Else
i = i + 1
End If
Loop
End Sub
Any guidance would be very much appreciated. Thank you

Answer 1

Move Criteria Rows Using AutoFilter
Sub Archive_Yes()
Const sName As String = "Sales Order Log"
Const sHeaderRowAddress As String = "A13:AA13"
Const CriteriaColumn As Long = 27
Const CriteriaString As String = "Yes"
Const dName As String = "Archive"
Const dFirstCellAddress As String = "A2"
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(sName)
If sws.AutoFilterMode Then sws.AutoFilterMode = False ' turn off AutoFilter
Dim srCount As Long
Dim srg As Range
With sws.Range(sHeaderRowAddress)
Dim slRow As Long
slRow = sws.Cells(sws.Rows.Count, CriteriaColumn).End(xlUp).Row
srCount = slRow - .Row + 1
If srCount < 2 Then Exit Sub ' no data or only headers
Set srg = .Resize(srCount)
End With
Dim scCount As Long: scCount = srg.Columns.Count
Dim sdrg As Range ' exclude headers and last column
Set sdrg = srg.Resize(srCount - 1, scCount - 1).Offset(1)
srg.AutoFilter CriteriaColumn, CriteriaString
Dim svrg As Range
On Error Resume Next
Set svrg = sdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
sws.AutoFilterMode = False
If svrg Is Nothing Then
MsgBox "No filtered rows.", vbExclamation
Exit Sub
End If
Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets(dName)
Dim dfCell As Range
With dws.Range(dFirstCellAddress)
Dim dlRow As Long
dlRow = dws.Cells(dws.Rows.Count, .Column).End(xlUp).Row
If dlRow < .Row Then
Set dfCell = .Cells
Else
Set dfCell = dws.Cells(dlRow + 1, .Column)
End If
End With
svrg.Copy dfCell
svrg.EntireRow.Delete Shift:=xlShiftUp
MsgBox "Data archived.", vbInformation
End Sub

Answer 2

Please, try the next adapted code:
Sub Archive_Yes()
Dim FirstRow As Long, LastRow As Long, Destination As Range, rngDel As Range
Dim ws As Worksheet, i As Long
Set ws = Sheets("Sales Order Log")
FirstRow = 14
LastRow = ws.cells(ws.rows.count, "AA").End(xlUp).row
For i = FirstRow To LastRow
If ws.Range("AA" & i).value = "Yes" Then
AddRange rngDel, ws.Range("A" & i & ":Z" & i)
End If
Next i
Dim wsA As Worksheet, lastRowA As Long
Set wsA = Sheets("Archive")
lastRowA = wsA.Range("A" & wsA.rows.count).End(xlUp).row + 1
If Not rngDel Is Nothing Then
Debug.Print rngDel.Address, lastRowA: Stop
Application.ScreenUpdating = False: Application.EnableEvents = False
Application.Calculation = xlCalculationManual
rngDel.Copy wsA.Range("A" & lastRowA)
rngDel.EntireRow.Delete
Application.ScreenUpdating = True: Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End If
End Sub
Sub AddRange(rngU As Range, rngAdd As Range)
If rngU Is Nothing Then
Set rngU = rngAdd
Else
Set rngU = Application.Union(rngU, rngAdd)
End If
End Sub
It should be very fast... Please, send some feedback after testing it.