Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cas As Byte, Existe As Boolean, x As Double, y As Double, Z As Single, Cellule As Range
'Contrôle de saisie sur une colonne unique
If Target.Column <> 3 And Target.Column <> 4 Then Exit Sub
If Target.Columns.Count > 1 Then
MsgBox "Vous ne pouvez saisir dans 2 colonnes"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Exit Sub
End If
Cas = IIf(Target.Column = 3, 0, 1)
'Traitement de chaque cellule modifiée
For Each Cellule In Target
If Cellule.Value <> 0 Then
Cible = Application.WorksheetFunction.NetworkDays(Cells(4, 5).Value, Cellule.Value) + 2 - Cas
With Cellule.Offset(0, Cible)
x = IIf(Cas = 0, .Left + 5, .Left + .Width - 12)
y = .Top
Z = (.Height - 7) / 2
End With
End If
'Verif forme existante
Existe = 0
For Each jalon In ActiveSheet.Shapes
If jalon.Top > Cellule.Top And jalon.Top < Cellule.Offset(1, 0).Top Then
If (jalon.ShapeStyle = msoShapeStylePreset39 And Cas = 0) Or (jalon.ShapeStyle = msoShapeStylePreset41 And Cas = 1) Then
If Cellule.Value = "" Then
jalon.Delete
Else
jalon.Left = x
End If
Existe = 1
Exit For
End If
End If
Next jalon
'Création
If Existe = 0 And Cellule.Value <> "" Then
If Cas = 0 Then
ActiveSheet.Shapes.AddShape(msoShapeDiamond, x, y + Z, 7, 7).Select
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset39
Else
ActiveSheet.Shapes.AddShape(msoShapeDiamond, x, y + Z, 7, 7).Select
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset41
End If
Target.Select
End If
Next Cellule
End Sub