Sub Перенос()
Dim item As Range, LastRow As Long, LastRowRNG As Long, j As Long
Dim rng As Range
LastRow = Sheets("АРХИВ").Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("ПРОДАЖИ")
    LastRowRNG = .Cells(.Rows.Count, 1).End(xlUp).Row
    For j = 5 To LastRowRNG
        If .Cells(j, 10).Value <> "" Then
            If rng Is Nothing Then
                Set rng = Rows(.Cells(j, 10).Row)
            Else
                Set rng = Union(rng, Rows(.Cells(j, 10).Row))
            End If
        End If
    Next j
    If Not rng Is Nothing Then
        rng.Copy Sheets("АРХИВ").Cells(LastRow + 1, 1)
        For Each item In rng.Areas
            item.EntireRow.Delete
        Next item
    rng = Nothing
    End If
End With
End Sub