Sub Arx()
    Dim d_ As Range
    Application.ScreenUpdating = 0
    With Me
        If .AutoFilter.FilterMode Then
            .ShowAllData
        End If
        .ListObjects(1).Range.AutoFilter Field:=13, Criteria1:="Архив"
        With .AutoFilter.Range
            drk_ = 0
            On Error Resume Next
            Set d_ = .Rows(2).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not d_ Is Nothing Then
                drk_ = d_.Cells.Count / d_.Columns.Count
                With Sheets("Архив")
                    r1_ = .Cells(.Rows.Count, 1).End(xlUp).Row
                    r0_ = 7
                    d_.Copy Destination:=.Cells(r1_ + 1, 1)
                    .Cells.FormatConditions.Delete
                    .Cells(r0_, 1).Resize(r1_ - r0_ + 1 + drk_).FormulaR1C1 = "=COUNT(R" & r0_ - 1 & "C:INDEX(C,ROW()-1))+1"
                End With
                Application.DisplayAlerts = 0
                d_.Rows.Delete
                Application.DisplayAlerts = 1
            End If
        End With
        .ShowAllData
    End With
    Application.ScreenUpdating = 1
    MsgBox "В архив перенесено записей: " & drk_
End Sub