Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal r As Range)
If Not Sh.Name Like "*_Dispatch*" Then Exit Sub
Application.EnableEvents = False
If r.Count > 1 Then Application.Undo: GoTo 1 'annulation des entrées/effacements multiples
Dim nom$, F As Worksheet, i As Variant, j%
nom = Application.Trim(r) 'SUPPRESPACE, sécurité
If nom = "" Then 'effacement
Application.Undo 'effacement annulé
If r <> "" Then MsgBox "Impossible to delete." & vbLf & _
"If needed enter " & r & " into the correct cell."
Else
Application.ScreenUpdating = False
Application.Undo
If r <> "" And r <> nom Then MsgBox r & " has to get first another posting !", 16: GoTo 1
If r = nom Then GoTo 1
Application.Undo
With Feuil10 'CodeName de la feuille POSTING, à adapter
Set F = Feuil11 'CodeName de la feuille ADRESSES, à adapter
i = Application.Match(nom, .Columns(1), 0)
If IsError(i) Then i = Application.CountA(.Columns(1)) + 1: _
.Cells(i, 1) = nom: F.Cells(i, 1) = nom 'nouvelle ligne
j = .Cells(i, .Columns.Count).End(xlToLeft).Column 'dernière cellule à droite
.Cells(i, j + 1) = r(2 - r.Row) & " / " & r(1, 2 - r.Column)
F.Cells(i, j + 1) = Sh.Name & "!" & r.Address(0, 0)
.Cells(1, j + 1) = "POSTING " & j: F.Cells(1, j + 1) = "POSTING " & j
If j > 1 Then Range(F.Cells(i, j)) = "" 'effacement de la position précédente
With .UsedRange
.WrapText = False
.Columns.AutoFit: F.Columns.AutoFit 'ajustement largeur
.Sort .Cells(1), xlAscending, Header:=xlYes 'tri
F.UsedRange.Sort F.Cells(1), xlAscending, Header:=xlYes 'tri en parallèle
End With
End With
End If
1 Application.EnableEvents = True
End Sub