XL 2019 Qu'est-ce qui ne va pas dans le code ... Colorer celulle B en fond vert si "COMPL" en C si date en D, B en fond jaune...

[anthoYS]

Bonjour,

-voir le fichier joint-

code vb :

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Application.Intersect(Target, Range("C:C")) Is Nothing Then
    If IsNumeric(Mid(Target.Value, Len(Target.Value), 1)) Then
      Target.Value = Mid(Target.Value, 1, Len(Target.Value) - 1) & Mid(Target.Value, Len(Target.Value), 1) + 1
    Else
      Target.Value = Target.Value & 1
    End If
  End If
  If Not Application.Intersect(Target, Range("B:B")) Is Nothing And IsEmpty(Target) Then
F_calendrier1dateTableur.Show
End If
Cancel = True
If Target.Column = 4 Then
Cells(Target.Row, 4) = Date
Cells(Target.Row, 2).Interior.color = vbYellow '  jaune
End If
If Target.Column = 4 Then
Cells(Target.Row, 4) = Date
Cells(Target.Row, 2).Interior.color = vbGreen ' Vert
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column <> 4 Then Exit Sub
    If Not IsEmpty(Target) Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, -1).Interior.color = vbYellow
        Target.Offset(0, -1).Font.Bold = True
    Else
        Target.Offset(0, 1).ClearContents
        Target.Offset(0, -1).Interior.color = xlNone
        Target.Offset(0, -1).Font.Bold = False
    End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
With Target
    If .Column = 3 Then
        Cancel = True
        If .Comment Is Nothing Then
            .AddComment
            .Comment.Shape.Width = 104.5
            .Comment.Shape.Height = 110.6
            .Comment.Shape.TextFrame.Characters.Font.Bold = True
        End If
        SendKeys "%im"
    End If
End With
Cancel = True
End Sub

A préciser si C est modifié mais sans "COMPL" alors colorer de jaune B. Chaque ligne est distincte...
Chaque double clic en C, fait monter le chiffre de droite en C, et fige la date d'aujourd'hui en D.


merci !

 

[anthoYS]

j'ai fini par trouver !!

Option Explicit


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Not Application.Intersect(Target, Range("C:C")) Is Nothing Then
    If IsNumeric(Mid(Target.Value, Len(Target.Value), 1)) Then
      Target.Value = Mid(Target.Value, 1, Len(Target.Value) - 1) & Mid(Target.Value, Len(Target.Value), 1) + 1
    Else
      Target.Value = Target.Value & 1
    End If
  End If
Cancel = True
If Target.Column = 4 Then
Cells(Target.Row, 4) = Date
Cells(Target.Row, 2).Interior.color = vbYellow '  jaune
End If
If Target.Column = 10 Then
Cells(Target.Row, 10) = Date
Cells(Target.Row, 9).Interior.color = vbGreen ' Vert
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column <> 3 Then Exit Sub
    If Not IsEmpty(Target) Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, -1).Interior.color = vbYellow
        Target.Offset(0, -1).Font.Bold = True
    Else
        Target.Offset(0, 1).ClearContents
        Target.Offset(0, -1).Interior.color = xlNone
        Target.Offset(0, -1).Font.Bold = False
    End If
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
With Target
    If .Column = 3 Then
        Cancel = True
        If .Comment Is Nothing Then
            .AddComment
            .Comment.Shape.Width = 104.5
            .Comment.Shape.Height = 110.6
            .Comment.Shape.TextFrame.Characters.Font.Bold = True
        End If
        SendKeys "%im"
    End If
End With
 If Not Application.Intersect(Target, Range("D:D")) Is Nothing And IsEmpty(Target) Then
F_calendrier1dateTableur.Show
End If
Cancel = True
End Sub