Sub Archiver()
'
Dim CelluleTrouvee As Range
Dim LigneArchive As Long
'
Application.ScreenUpdating = False
LigneArchive = Sheets('ArchivageFR').Range('A65536').End(xlUp).Row + 1
Sheets('Priorités').Activate
Range('P
').Select
Set CelluleTrouvee = Selection.Find(what:='oui', LookIn:=xlValues)
Do While Not CelluleTrouvee Is Nothing
CelluleTrouvee.EntireRow.Copy Sheets('ArchivageFR').Rows(LigneArchive)
CelluleTrouvee.EntireRow.Delete
LigneArchive = LigneArchive + 1
Set CelluleTrouvee = Selection.FindNext
Loop
Range('A1').Select
End Sub