création automatique d'onglet dans un classeur

Sub CreationFeuilles()
Dim F As Worksheet, ref1 As Range, ref2 As Range
Application.ScreenUpdating = False
[COLOR="Red"]Application.DisplayAlerts = False
On Error Resume Next[/COLOR]
Set F = ActiveSheet
Set ref1 = [A2]
While ref1 <> ""
Set ref2 = ref1.Offset(Application.CountIf(F.[A:A], ref1.Value))
Set plage = F.Range(ref1.Offset(, 1), ref2.Offset(-1, 1))
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = ref1
[COLOR="Red"]If Err Then Sheets(Sheets.Count).Delete: Err = 0[/COLOR]
plage.Copy Sheets(ref1.Value).[A1]
Set ref1 = ref2
Wend
F.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub Extrait()
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  [G:G].Insert
  [G1] = [A1]
  shBD = ActiveSheet.Name
  Range("A1:A10000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("G1"), Unique:=True
  For Each c In Range("G2", [G65000].End(xlUp)) ' pour chaque objet
    Sheets(shBD).[G2] = c.Value
    On Error Resume Next
    Sheets(c.Value).Delete
    On Error GoTo 0
    Sheets.Add After:=Sheets(Sheets.Count) ' création
    ActiveSheet.Name = c.Value
    Sheets(shBD).[A1:B10000].AdvancedFilter Action:=xlFilterCopy, _
       CriteriaRange:=Sheets(shBD).[G1:G2], CopyToRange:=[A1]
  Next c
  Sheets(shBD).[G:G].Delete
End Sub