Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, n As Long
Set r = Intersect(Target, [A:A], Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
For Each r In r
n = r.MergeArea.Rows.Count
If n > 1 Then
r.UnMerge 'défusionne
r(1, 2).Resize(n).ClearContents
If IsEmpty(r) Then r(2, 1).Resize(n - 1, 2).Delete xlUp
End If
n = Int(Val(r.Text))
If n > 0 Then r(1, 2) = 1
If n > 1 Then
r(2, 1).Resize(n - 1, 2).Insert xlDown
r(2, 2).Resize(n - 1) = 1
r.Resize(n).Merge 'fusionne
End If
Next
If Target(1).MergeArea.Count > 1 Then Target.Select
Application.EnableEvents = True
End Sub