Option Explicit
Sub Extraire()
Dim o As Worksheet
Dim mot As String
Application.ScreenUpdating = False
mot = Sheets("Feuil2").Range("g2").Value
Sheets("Feuil2").Range("a2:d60000").Clear
For Each o In Worksheets
If o.Name <> "Feuil2" Then
o.Activate
o.Range("b1").AutoFilter Field:=2, Criteria1:=mot
o.Range(Range("a2"), Range("a2").End(xlToRight).End(xlDown)).Copy Destination:=Sheets("Feuil2").Range("a65536").End(xlUp).Offset(1, 0)
o.Range("b1").AutoFilter
End If
Next
Sheets("Extrait").Activate
Application.ScreenUpdating = True
End Sub