Code qui insère la date du jour en L, mais comment faire pour ne pas pouvoir l'écrasé

[anthoYS]

bonsoir,

voici un code qui permet d'ajouter par double clic en L (colonne n°12) la date du jour du double clic dans la cellule concerné. Je souhaite que si je reclique dans une cellule contenant déjà une date, on ne puisse pas la modifier. Car cela peut arriver par accident. Qui serait modifier ce code en vue d'obtenir ce que je souhaite. Le double clic qui rajoute la date doit être actif si et seulement si la cellule du double clic ne contient rien, est vide.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)If Not Application.Intersect(Target, Range("K:K")) Is Nothing And IsEmpty(Target) Then
Cells(Target.Row, 11) = Date
End If
If Not Application.Intersect(Target, Range("J:J")) Is Nothing And IsEmpty(Target) Then
Calendrier.Show
End If
Cancel = True
If Target.Column = 12 Then
Cells(Target.Row, 12) = Date
End If
If Target.Column = 8 Then
Cells(Target.Row, 1).Interior.ColorIndex = 4
Cells(Target.Row, 2).Interior.ColorIndex = 4
Cells(Target.Row, 3).Interior.ColorIndex = 4
Cells(Target.Row, 5).Interior.ColorIndex = 4
Cells(Target.Row, 6).Interior.ColorIndex = 4
Cells(Target.Row, 7).Interior.ColorIndex = 4
End If
If Target.Column = 9 Then
Cells(Target.Row, 1).Interior.ColorIndex = 15
Cells(Target.Row, 2).Interior.ColorIndex = 15
Cells(Target.Row, 3).Interior.ColorIndex = 15
Cells(Target.Row, 5).Interior.ColorIndex = 15
Cells(Target.Row, 6).Interior.ColorIndex = 15
Cells(Target.Row, 7).Interior.ColorIndex = 15
End If
If Target.Column = 13 Then
Cells(Target.Row, 13).Interior.ColorIndex = 4
Cells(Target.Row, 13) = Date
End If
  If Target.Column = 10 And Target.Count = 1 Then
    '-- suppression
    For Each S In ActiveSheet.Shapes
      If S.Type = 8 Then
        If S.TopLeftCell.Address = Target.Address Then S.Delete
      End If
    Next S
    '--
    If Target <> "" Then
      On Error Resume Next
      Sheets("mdP").Shapes(Target).Copy
      If Err = 0 Then
        ActiveSheet.Paste
        largeurImage = Sheets("mdP").Shapes(Target).Width
        HauteurImage = Sheets("mdP").Shapes(Target).Height
        Selection.ShapeRange.Left = ActiveCell.Left + ActiveCell.Width / 2 - largeurImage / 2
        Selection.ShapeRange.Top = ActiveCell.Top + 0
        Rows(Target.Row).RowHeight = 39
        Target.Select
      End If
    End If
   End If
End Sub

merci 😀

à+

 

[phlaurent55]

Re : Code qui insère la date du jour en L, mais comment faire pour ne pas pouvoir l'é

Bonjour Anthony,

avec ce code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("L:L")) Is Nothing And IsEmpty(Target) Then
Target = Date
End If
End Sub

à+
Philippe