Colorer, plus rapide que supprimer ?

Bonjour a tous !
Il fait pas beau dehors, j'ai besoin de vacances ... mais il y a le
Newsgroup :D.
Je cherche comme precise dans mes posts precedents a colorer en rouge un
code qu'on retrouve plusieurs fois. J'ai fait un super code simple, et qui
semble tres bien marcher. Ce code traite aussi bien les doublons que les
triplets et les 100-tuplets ...
S'il trouve plusieurs fois un meme code dans la colonne A, il colore la
premiere cellule en vert et les autres en rouge. S'il trouve le code une
seule fois, il la colore en gold.
Dans mon code, j'ai ajoute deux lignes pour pouvoir supprimer la ligne qu'on
aurait coloree en rouge.
La coloration en vert, rouge, gold prend une seconde pour 6000 lignes.
Par contre, la coloration en vert, gold et la suppression prend beaucoup
plus de temps. Une minute et ce n'est pas encore fini !
Petit souci d'optimisation me diriez vous !
Donc, est t'il possible de rendre cette suppression plus rapide en changeant
un peu mon code (ne pas le refaire en gros) ?
N.B : le classement decroissant de la colonne E, c'est pour moi.

Sub CodesMult()
' Classement croissant de la colonne A et decroissant de la colonne E
Columns("A:F").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:= _
Range("E1"), Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1,
_
MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
Set Code = Range("A1")
Application.ScreenUpdating = False
Do While Not IsEmpty(Code)
Set CodeSuite = Code.Offset(1, 0)
If CodeSuite.Value = Code.Value Then
Code.Interior.ColorIndex = 4
Do While CodeSuite.Value = Code.Value
CodeSuite.EntireRow.Delete ' POUR SUPPRIMER LA LIGNE
Set CodeSuite = Code.Offset(1, 0) ' POUR SUPPRIMER LA LIGNE
'POUR COLORER EN ROUGE CodeSuite.Interior.ColorIndex = 3
'POUR COLORER EN ROUGE Set CodeSuite = CodeSuite.Offset(1, 0)
Loop
ElseIf CodeSuite.Value <> Code.Value Then
Code.Interior.ColorIndex = 44 ' Couleur Gold
End If
Set Code = CodeSuite
Loop
Application.ScreenUpd