Sub Remplacer()
Dim t#, r As Range, P As Range, v As Variant, n&
t = Timer
With Feuil1
Set r = Intersect(.UsedRange.EntireRow, .[E:AD])
End With
Application.ScreenUpdating = False
On Error Resume Next
With Workbooks.Open(ThisWorkbook.Path & "\liste.xlsx")
If Err Then MsgBox "Fichier 'liste.xlsx' introuvable...": Exit Sub
On Error GoTo 0
Set P = .Sheets(1).[A:B]
For Each r In r
If r <> "" Then If r.Interior.ColorIndex <> xlNone Then v = Application.VLookup(r, P, 2, 0): If Not IsError(v) Then r = v: n = n + 1
Next
.Close False
End With
Application.ScreenUpdating = True
MsgBox n & " remplacements effectués en " & Format(Timer - t, "0.00 \sec")
End Sub