Incrémentation d'une cellule sur des feuilles successives

Sub AjouterFeuilles()
Dim n As Variant, i As Byte
With Worksheets(1)
If Val(.[A4]) = 0 Then Application.Goto .[A4]: MsgBox "Renseignez la cellule A4": Exit Sub
n = InputBox("Nombre de feuilles :", "Ajouter feuilles")
n = Application.Min(Abs(Int(Val(n))), 54 - Worksheets.Count) 'limité à 54 semaines
If n Then
  Application.ScreenUpdating = False
  For i = 1 To n
    .Copy After:=Sheets(Sheets.Count)
  Next
  [A4] = [A4]
End If
End With
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
If [COLOR="red"]Sh.Index < 2 Or[/COLOR] Intersect(Source, Sh.[A1:A4]) Is Nothing Then Exit Sub
Dim F As Object, i As Integer 'Integer au cas où le nombre de feuilles dépasse 254
Application.ScreenUpdating = False 'fige l'écran
On Error Resume Next
Set F = ActiveSheet
Worksheets([COLOR="red"]2[/COLOR]).Activate
If F.Index > [COLOR="Red"]2[/COLOR] Then [A4] = [A4] 'déclanche cette macro
If Sh.Index = [COLOR="red"]2[/COLOR] And IsNumeric(CStr([A4])) Then
  For i = [COLOR="red"]2[/COLOR] To Worksheets.Count
    Worksheets(i).Name = i 'nomme provisoirement les feuilles 2 3 4 5...
  Next
  For i = [COLOR="red"]3[/COLOR] To Worksheets.Count
    Worksheets(i).[A1:A3] = [A1:A3].Formula 'déclanche cette macro
    Worksheets(i).[A4] = [A4] + i - [COLOR="red"]2 [/COLOR]'déclanche cette macro
  Next
End If
Sh.Name = Sh.[A1]
F.Activate
End Sub