merci de votre aide,
je suis desolé pour cette expression " prière de revoir " je pensais pas que cela pouvais choqué.
neamoins tu m'a deja beaucoup aidé. seulement je vais joindre le nouveau fichier si vous pouvez encore avoir un p de temps pour moi.
Il marche bien ce code seulement il me fait une decrementation de -1 des enregistrement qu'il doit normalement recuperé.
Sub Extract()
Application.ScreenUpdating = False
Dim Ws1, Ws2 As Worksheet
Dim Couleurs, MonDico, C, mRange
Set Ws1 = Sheets("feuil1"): Set Ws2 = Sheets("Feuil2")
Set MonDico = CreateObject("Scripting.Dictionary")
last = Ws1.[F65000].End(xlUp).Row
Set mRange = Ws1.Range("E1:E" & last)
For Each C In mRange
If C <> "0" Then MonDico.Item(C.Value) = MonDico.Item(C.Value) + 1
If MonDico.Item(C.Value) > 1 Then
C.Interior.ColorIndex = 33
Set desti = Ws2.[A65000].End(xlUp)
C.EntireRow.Copy Destination:=desti(2)
End If
Next C
End Sub
cordialement