Changer les couleurs de plusieurs cellules

[titi32600]

Bonjour à tous

besoin d'aide en VBA

J'ai une feuille "Feuille1", où la date d’aujourd’hui est notée en C1.

Une série de date sont affichées en B6, C6, D6.
je souhaiterais, que les cellules B6:Q6, change de couleur quand la date notée en D6 est plus petite que celle affichée en C1, et que soit noté en Q6, la mention "OK".
Si D6 est plus grand que C1, alors rien n'est changé.
Je souhaiterais, faire cela de la ligne B6 à B15

Effectivement, je pourrais faire avec la mise en forme conditionnelle, mais je préférerais en VBA.

Dans l'exemple joint, un code à été déjà mis en place, mais il ne fonctionne que pour une ligne, mais j'ai un peu de mal, à concentrer ce code pour les lignes allant de B6 à B15

merci encore pour votre aide

titi32600

 

[jecherche]

Bonjour,

Une proposition sans limite de lignes :

Private Sub Worksheet_Change(ByVal Target As Range)

Dim dt1 As Date
Dim dt2 As Date
Dim DerLig As Integer
Dim X As Integer

If Target.Count > 1 Then
   Exit Sub
End If

If Not Intersect(Target, Range("D:D")) Is Nothing Then
   DerLig = Range("D" & Rows.Count).End(xlUp).Row
   For X = 6 To DerLig
      If DateDiff("D", Range("C1").Value, Range("D" & X).Value) < 0 Then
         Range("B" & X & ":Q" & X).Interior.Color = RGB(230, 215, 200)
         Range("Q" & X).Value = "OK"
      Else
         Range("B" & X & ":Q" & X).Interior.Color = RGB(255, 255, 255)
         Range("Q" & X).Value = ""
      End If

   Next X
End If
End Sub

Jecherche

 

[CISCO]

Bonjour à tous, bonjour Jecherche

Peut être avec quelque chose du genre

Private Sub Worksheet_Change(ByVal Target As Range)
  
    Dim dt1 As Date
    Dim dt2 As Date
    Dim i As Integer
  
    If Target.Count > 1 Then
        Exit Sub
    End If
  
    For i = 6 To 15
    If Target.Address = "$C$1" Or Target.Address = Cells(i, 4).Address Then
        If DateDiff("d", Range("C1").Value, Cells(i, 4).Value) < 0 Then
            Range(Cells(i, 2), Cells(i, 17)).Interior.Color = RGB(230, 215, 200)
            Cells(i, 17).Value = "OK"
        Else
            Range(Cells(i, 2), Cells(i, 17)).Interior.Color = RGB(255, 255, 255)
            Cells(i, 17).Value = ""
        End If
    End If
    Next i
End Sub

@ plus

 

[sousou]

Bonjour
J'y vais de ma proposition si j'ai tout compris??

 

[Staple1600]

Bonjour à tous

[juste de passage]
Cela doit être la semaine du Long, cette semaine
Logiquement, il est plus prudent d'écrire
Dim DerLig As Long
Parce qu'avec Dim DerLig As Integer, on peut avoir des surprises
Mais comme disait Regis :" C'est vous qui voyez"
[/juste de passage]

NB: Dans la foulée, Dim X As Long serait aussi plus prudent.

 

[titi32600]

Merci encore à vous tous

la façon de CISCO, me convient très bien, mais les exemples de SOUSOU, et JECHERCHE, sont à retenir aussi.

cordialement

 

[titi32600]

seul petit bémol,

les lignes vide, sont aussi misent en couleur RGB (230, 215, 200), avec la mention OK dans les cellules Q, alors qu'elles devraient restées en blanc, sans mention.

cordialement

 

[jecherche]

Bonjour,

Est-ce toutes les propositions qui ont se résultat ?
Sinon, laquelle a ce comportement ?


Jecherche

 

[jecherche]

Bonjour,

En relisant, je comprends que tu as utilisé le code de Cisco.
Pour corrigé le bug mentionné, j'ai osé le modifié un tantinet...

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim dt1 As Date
    Dim dt2 As Date
    Dim i As Integer

    If Target.Count > 1 Then
        Exit Sub
    End If

    For i = 6 To 15
    If Target.Address = "$C$1" Or Target.Address = Cells(i, 4).Address Then
        If Cells(i, 4) <> "" Then   '' ajout si cellule différente de vide
           If DateDiff("d", Range("C1").Value, Cells(i, 4).Value) < 0 Then
               Range(Cells(i, 2), Cells(i, 17)).Interior.Color = RGB(230, 215, 200)
               Cells(i, 17).Value = "OK"
            Else
               Range(Cells(i, 2), Cells(i, 17)).Interior.Color = RGB(255, 255, 255)
               Cells(i, 17).Value = ""
            End If
         Else  '' ajout
            Range(Cells(i, 2), Cells(i, 17)).Interior.Color = RGB(255, 255, 255)  '' ajout
            Cells(i, 17).Value = ""   '' ajout
         End If   '' ajout
    End If
    Next i
End Sub

Jecherche

 

[titi32600]

Salut Jecherche

j'ai utilisé le résultat de SOUSOU

merci

 

[jecherche]

Bonjour,

Dans ce cas, sans permission de sousou, change cette macro ...

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
       
If Target.Row = 1 And Target.Column = 3 Then
   mesdonnées = "$d$6:$d$15   "
   Set zone = ActiveSheet.Range(mesdonnées)
   For Each i In zone
      If CDate(i) <= Target And i <> "" Then Call couleur(i.Row, couleur1, True) Else Call couleur(i.Row, couleur2, False)
   Next
End If
End Sub

Jecherche

 

[titi32600]

Re

Plus aucun problème.

En fait, j'ai repris le code de CISCO, que tu viens de modifier.

Il me convient à merveille.

Merci encore de ton aide

 

[jecherche]

Bonjour,




Jecherche