Option Explicit
Sub Extraire()
Application.ScreenUpdating = False
Cells.Clear
Range("a1") = "couleur"
Range("a2") = ActiveSheet.Name
Sheets("DataBase").Columns("A:F").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Range("a1:a2"), CopyToRange:=Range("b1:g1"), Unique:=False
Columns("a:a").Delete Shift:=xlToLeft
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub