Sub transfert()
Application.ScreenUpdating = False
With Sheets("relever")
.Range("A7:J" & .[A65000].End(xlUp).Row).Name = "base"
.[Z1] = .[A7]
.Range("A7:A" & .[A65000].End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range( _
"Z1"), Unique:=True
.Range("Z1:Z" & .[Z65000].End(xlUp).Row).Sort Key1:=.Range("Z2"), Order1:=xlAscending, Header:=xlYes
For Each cel In .Range("Z2:Z" & .[Z65000].End(xlUp).Row)
.[Z2] = cel
.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = cel
.Range("base").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("Z1:Z2"), CopyToRange:=Range("A7:J7" _
), Unique:=False
Next cel
.Columns(26).Delete
.Select
End With
End Sub