Sub Extrait()
Set f = Sheets("base")
f.[ag1] = f.[ad1]
f.[A1:AD10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=f.[ag1], Unique:=True
For Each c In f.Range("AG2", f.[AG65000].End(xlUp)) ' pour chaque travée
On Error Resume Next
temp = CStr(c.Value)
Sheets(temp).Delete
On Error GoTo 0
Sheets("modèle").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
ligne = 2
For i = 2 To f.[A65000].End(xlUp).Row
If CStr(f.Cells(i, "AD")) = temp Then
Cells(ligne, "A") = f.Cells(i, "AD")
Cells(ligne, "J") = f.Cells(i, "H")
Cells(ligne, "I") = f.Cells(i, "G")
ligne = ligne + 1
End If
Next i
Next c
End Sub