Sub extait()
With Worksheets("Feuil1").Range("a:a")
Set c = .Find("Display ID", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
adresses = adresses & c.Address(0, 0) & ":"
n = n + 1
Set c = .FindNext(c)
Loop While n < 2
End If
End With
ad = Left(adresses, Len(adresses) - 1)
linh = Range(ad).Row + 1
linb = linh + Range(ad).Rows.Count - 3
ActiveSheet.Rows(linh & ":" & linb).Copy Destination:=[COLOR=red]Sheets("Feuil2").Range("A1")
[/COLOR]End Sub