Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Right(Sh.Name, 4) Like "####" Or Target.Address <> "$A$1" Then Exit Sub
Dim memAn, nf$
memAn = Sh.[A1] 'mémorise l'année
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
Application.Undo 'annule l'entrée
If Not Sh.[A1] Like "####" Then GoTo 1
Target.Select
nf = Sh.Name & " " & Sh.[A1] 'nom pour l'archive
If MsgBox("Voulez-vous créer l'archive '" & nf & "' ?", vbYesNo) = vbNo Then GoTo 1
'---crée l'archive---
Application.DisplayAlerts = False
On Error Resume Next 'si la feuille n'a pas été créée
Sheets(nf).Delete
Sheets.Add Before:=Sh 'nouvelle feuille...