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

CodePudding user response：

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.FilterMode Then sws.ShowAllData
    
    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

CodePudding user response：

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
    With Sheets("Archive")
       Set Destination = .cells(.rows.count, "A").End(xlUp).Offset(1, 0)
    End With
    If Not rngDel Is Nothing Then
        Application.ScreenUpdating = False: Application.EnableEvents = False
        Application.Calculation = xlCalculationManual
          rngDel.Copy Destination
          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.