Nomer une feuille automatiquement

Option Explicit
Private Sub CommandButton1_Click()
Dim dlg As FileDialog
Dim c As Workbook
Dim f As Worksheet
Dim d As Date
Dim n As String
Dim a As Integer
Dim i As Integer

  'Désélectionner le bouton
  ActiveCell.Activate
  'Date actuelle
  d = CDate("1 " & Me.Name)
  'Année actuelle
  a = Year(d)
  'Date mois suivant
  d = DateSerial(a, Month(d) + 1, 1)
  'Nom de la feuille
  n = Application.Proper(Format(d, "mmm yyyy"))
  If a = Year(d) Then
    ' si la feuille suivante est dans la même année ....
    On Error Resume Next
    Set f = Worksheets(n)
    On Error GoTo 0
    If f Is Nothing Then
      ' - si la feuile n'existe pas, l'ajouter.
      Me.Copy after:=Me
      Set f = ActiveSheet
      f.Name = n
    Else
      ' - si la feuille existe, la sélectionner
      f.Activate
    End If
  Else
    ' si on change d'année, copier la feuille dans un nouveau classeur
    Me.Copy
    Set f = ActiveSheet
    f.Name = n
    Set c = f.Parent
    ' proposer l'enregistrement du nouveau classeur
    Set dlg = Application.FileDialog(msoFileDialogSaveAs)
    With dlg
      ' nom du fichier
      .InitialFileName = ThisWorkbook.Path & "\" & "Fact " & Year(d)
      ' filtrer sur l'extension *.xls
      For i = 1 To .Filters.Count
        If .Filters(i).Extensions = "*.xls" Then
          .FilterIndex = i
          Exit For
        End If
      Next i
      If .Show <> 0 Then
        'Enregistrer le classeur
        On Error Resume Next
        Application.DisplayAlerts = False
        .Execute
        Application.DisplayAlerts = True
        On Error GoTo 0
      End If
    End With
  End If

End Sub