Sub Macro2()
Dim pl As Range
Set pl = Sheets("Feuil1").Range("base")
pl.Name = "base"
For Each sh In Sheets
If sh.Name <> "Feuil1" Then
With sh
.[K1] = "Nom"
.[K2] = sh.Name
pl.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.[K1:K2], CopyToRange:=.Range("A1:i1"), Unique:=False
.[K1:K2].ClearContents
End With
End If
Next sh
End Sub