Сдвиньте диапазон вверх после очистки содержимого

Попробуйте этот мод

Sub Test()
    Dim ws          As Worksheet
    Dim e           As Variant
    Dim lr          As Long
    Dim r           As Long
    Dim range_to_del as Range

    Set ws = ThisWorkbook.Sheets("Current")
    Set range_to_del = ws.Range("CCC1")  'set to a cell somewhere at the right end of the sheet which column is not used
    With Sheets("Archive")
        For r = 1 To ws.Cells(Rows.Count, 2).End(xlUp).Row
            If ws.Cells(r, 4) = "Done" Then
                lr = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                For Each e In Array("A", "B", "C", "D", "E")
                    .Range(e & lr) = ws.Range(e & r)
                Next e
                Set range_to_del = Union(range_to_del, ws.Range("A" & r & ":E" & r))
           End If
        Next r
    End With
    range_to_del.Delete xlShiftUp
    
'    Range("A:E").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
    
End Sub

range_to_del собирает скопированные строки и в конце копирования удаляет скопированные строки с листа Current.

Копировать совпадающие строки (архивные данные)

До

После

Sub ArchiveData()
    Const PROC_TITLE As String = "Archive Data"
    Dim Msg As String
    On Error GoTo ClearError ' out-comment if error message to troubleshoot!
    
Msg = "Defining constants"
    
    ' Source
    Const SRC_SHEET_NAME As String = "Current"
    Const SRC_COLUMNS As String = "A:E"
    Const SRC_FIRST_ROW As Long = 2
    Const SRC_SEARCH_COLUMN As Long = 4 ' n-th column of 'SRC_COLUMNS'!
    Const SRC_SEARCH_STRING As String = "Done"
    ' Destination
    Const DST_SHEET_NAME As String = "Archive"
    Const DST_FIRST_CELL_ADDRESS As String = "A2"
    ' Other
    Const MATCH_CASE As Boolean = False
    Const DO_NOT_DELETE_ROWS As Boolean = True ' reset when finished testing!
    Const SHOW_MESSAGES As Boolean = True
    
Msg = "Referencing the workbook"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
Msg = "Retrieving source information"
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    If sws.FilterMode Then sws.ShowAllData
    
    Dim srg As Range, sfrg As Range, slcell As Range, sRowsCount As Long
    
    With sws.Rows(SRC_FIRST_ROW).Columns(SRC_COLUMNS) ' first row
        Set sfrg = .Resize(sws.Rows.Count - .Row + 1) ' find range
        Set slcell = sfrg.Find(What: = "*", LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        If slcell Is Nothing Then ' last non-empty cell by rows
            If SHOW_MESSAGES Then
                MsgBox "No data found in ""'" & sws.Name & "'!" _
                    & sfrg.Address(0, 0) & """!", vbExclamation
                Exit Sub
            End If
        End If
        sRowsCount = slcell.Row - .Row + 1
        Set srg = .Resize(sRowsCount)
    End With
    
    Dim scrg As Range: Set scrg = srg.Columns(SRC_SEARCH_COLUMN) ' search range
    
    Dim scData() As Variant:
    If sRowsCount = 1 Then
        ReDim scData(1 To 1, 1 To 1)
        scData(1, 1) = scrg.Value
    Else
        scData = scrg.Value
    End If
    
    Dim ColumnsCount As Long: ColumnsCount = srg.Columns.Count
    
    If ColumnsCount < SRC_SEARCH_COLUMN Then
        MsgBox "The source range ""'" & sws.Name & "'!" _
            & srg.Address(0, 0) & """ has fewer than " & SRC_SEARCH_COLUMN _
            & " columns!", vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
Msg = "Combining matching rows into unioned range"
    
    Dim CompareMethod As Long: CompareMethod = MATCH_CASE + 1
    
    Dim surg As Range, srrg As Range, sValue As Variant
    Dim sRow As Long, dRowsCount As Long, WasSearchStringFound As Boolean
    
    For sRow = 1 To sRowsCount
        sValue = scData(sRow, 1)
        If Not IsError(sValue) Then
            If StrComp(sValue, SRC_SEARCH_STRING, CompareMethod) = 0 Then
                dRowsCount = dRowsCount + 1
                Set srrg = srg.Rows(sRow)
                If WasSearchStringFound Then
                    Set surg = Union(surg, srrg)
                Else
                    Set surg = srrg
                    WasSearchStringFound = True
                End If
            End If
         End If
    Next sRow
        
    If Not WasSearchStringFound Then
        If SHOW_MESSAGES Then
            MsgBox "No rows with """ & SRC_SEARCH_STRING & """ in ""'" _
                & sws.Name & "'!" & scrg.Address(0, 0) & """ found!", _
                vbExclamation, PROC_TITLE
        End If
        Exit Sub
    End If
            
Msg = "Retrieving destination information"
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
    If dws.FilterMode Then dws.ShowAllData
    
    Dim drg As Range, dfrg As Range, dlcell As Range, dRowOffset As Long
    
    With dws.Range(DST_FIRST_CELL_ADDRESS).Resize(, ColumnsCount) ' first row
        Set dfrg = .Resize(dws.Rows.Count - .Row + 1) ' find range
        Set dlcell = dfrg.Find(What: = "*", LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        If Not dlcell Is Nothing Then  ' last non-empty cell by rows
            dRowOffset = dlcell.Row - .Row + 1
        End If
        Set drg = .Offset(dRowOffset).Resize(dRowsCount)
    End With
    
Msg = "Archiving rows"
            
    surg.Copy Destination:=drg
    Dim sAddress As String: sAddress = srg.Address(0, 0)
    Dim scAddress As String: scAddress = scrg.Address(0, 0)
    If Not DO_NOT_DELETE_ROWS Then surg.Delete Shift:=xlShiftUp
    
Msg = "Informing"
        
    If SHOW_MESSAGES Then
        MsgBox dRowsCount & " row" & IIf(dRowsCount = 1, "", "s") & " of ""'" _
            & sws.Name & "'!" & sAddress & """ with """ _
            & SRC_SEARCH_STRING & """ in """ & scAddress & " " _
            & IIf(DO_NOT_DELETE_ROWS, "copie", "move") & "d to ""'" _
            & dws.Name & "'!" & drg.Address(0, 0) & """.", _
            vbInformation, PROC_TITLE
    End If
    
ProcExit:
    Exit Sub
ClearError: ' e.g. not enough rows in the destination sheet
    MsgBox "Run-time error [" & Err.Number & "]: (while " & LCase(Msg) & ")" _
        & vbLf & vbLf & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub