Sub CreerFeuilles()
'Feuil1 Feuil2 (à adapter) sont les CodeName des feuilles
Dim F As Object, cel As Range
Set F = ActiveSheet
Application.ScreenUpdating = False
On Error Resume Next
For Each cel In Feuil1.Range("B5:B" & Feuil1.Rows.Count) _
.SpecialCells(xlCellTypeConstants, 2)
If IsError(Sheets(cel.Text).Name) Then
Feuil2.Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = cel
Sheets(cel.Text).[D1] = cel
End If
Next
F.Activate
End Sub