Sub FromBazaToArhiv()
Dim arrArhiv()
Dim dicArt As Object
Application.ScreenUpdating = False
    arrBaza = Range("A2:Q" & Cells(Rows.Count, "I").End(xlUp).Row).Value
    arrArt = Range("S2:S" & Cells(Rows.Count, "S").End(xlUp).Row).Value
    Set dicArt = CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(arrBaza)
        dicArt.Add arrBaza(I, 9), I
    Next
    For I = 1 To UBound(arrArt)
        If dicArt.Exists(arrArt(I, 1)) Then
            ReDim Preserve arrArhiv(UBound(arrBaza, 2), N)
            For J = 0 To UBound(arrArhiv) - 1
                arrArhiv(J, N) = arrBaza(dicArt(arrArt(I, 1)), J + 1)
            Next
            iRow = dicArt(arrArt(I, 1)) + 1 - N
            Range("A" & iRow & ":Q" & iRow).Delete Shift:=xlUp
            N = N + 1
        End If
    Next
With Worksheets("Архив БД")
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range("A" & lRow).Resize(UBound(arrArhiv, 2) + 1, UBound(arrArhiv, 1)) = Application.Transpose(arrArhiv)
End With
Application.ScreenUpdating = True
End Sub

dicArt.Add arrBaza(I, 9), I