[Excel2016] Texte dans une cellule en fonction de la couleur d'une autre

 Option Explicit

Const codat = "N"   ' colonne date
Const coeta = "O"   ' colonne etat accord
' codes couleurs
Const rouge = &HFF
Const orange = &H1175D9
Const jaune = &H9C4FF
Const vert = &H6600
Const noir = &H0

Private Sub Worksheet_Change(ByVal Target As Range)
'Ouverture d'une procédure Sub pour modifier le contenu de la colonne I de la feuille Liste Accords
'Ci-dessous déclaration de la variable V1 comme plage de cellule avec l'instruction DIM ... As Range
Dim Vl As Range
Dim d As Date, li As Long, c As Range, m As Long, a As Long, j As Long
Dim dm6 As Date, dm3 As Date, am6 As Long, mm6 As Long, mm3 As Long, am3 As Long
Dim dd As Date
'Instruction ci-dessous : la procédure se déclenche quand clic n'importe où dans la colonne I uniquement
  If Not Intersect([I:I], Target) Is Nothing And Target.Count = 1 Then
'désactive les événements
    Application.EnableEvents = False
'Valeurs de la plage
    ValSaisie = Target
    Application.Undo
    p = InStr(Target, ValSaisie)
    If p > 0 Then
      Target = Left(Target, p - 1) & Mid(Target, p + Len(ValSaisie) + 1)
      If Right(Target, 1) = Chr(10) Then
        Target = Left(Target, Len(Target) - 1)
      End If
    Else
        If Target = "" Then
          Target = ValSaisie
        Else
          Target = Target & Chr(10) & ValSaisie
        End If
    End If
    Application.EnableEvents = True
 End If
 'Fin de la procédure Sub pour modifier le contenu de la colonne I de la feuille Liste Accords
'Si plus d'une cellule est sélectionnée, fin de la Sub...
If Target.Count > 1 Then Exit Sub
'Attribution de la plage Col. J à la variable V1 avec instruction SET
Set Vl = Range("J:J")
'La procédure se déclenche quand on clique n'importe où dans la colonne J uniquement
If Not Intersect(Vl, Target) Is Nothing Then
Application.EnableEvents = False
'La valeur target comprendra les 3 premières lettres de la valeur affichée dans la cellule après choix liste déroulante
    Target = Left(Target, 3)
    Application.EnableEvents = True
End If

' si plus d'une cellule changée, on quitte
If Target.Count > 1 Then Exit Sub
' si on est en colonne codat on y va
If Not Intersect(Target, Columns(codat)) Is Nothing Then
  ' date du jour + année, mois jour de la date du jour
  dd = Date
  a = Year(dd): m = Month(dd): j = Day(dd)
  ' date saisie
  d = Target.Value
  ' calcul dd + 6 mois
  If m > 6 Then
     am6 = a + 1: mm6 = (m + 6) Mod 12
  Else
     am6 = a: mm6 = m + 6
  End If
  dm6 = CDate(j & "/" & mm6 & "/" & am6)
  ' calcul dd + 3 mois
  If m > 9 Then
    am3 = a + 1: mm3 = (m + 3) Mod 12
  Else
    am3 = a: mm3 = (m + 3)
  End If
  dm3 = CDate(j & "/" & mm3 & "/" & am3)
  ' c = cellule à remplir
  li = Target.Row
  Set c = Range(coeta & li)
  ' remplir c selon les 3 cas envisagées
  Select Case d
    ' cas : date du jour < date saisie
    Case Is < dd:
      c.Value = "Expiré": c.Font.Color = rouge
      c.Font.Bold = True
    ' date du jour inférieure à date du jour + 3 mois
    Case Is < dm3:
      c.Value = "Expiré dans moins de 3 mois"
      c.Font.Color = noir
      c.Characters(Start:=1, Length:=6).Font.Color = rouge
      c.Characters(Start:=1, Length:=6).Font.Bold = True
      c.Characters(Start:=22, Length:=6).Font.Color = rouge
      c.Characters(Start:=22, Length:=6).Font.Bold = True
    ' date du jour inférieure à date du jour + 6 mois
    Case Is < dm6:
      c.Value = "Expiration dans moins de 6 mois"
      c.Font.Color = noir
      c.Characters(Start:=1, Length:=10).Font.Color = rouge
      c.Characters(Start:=1, Length:=10).Font.Bold = True
      c.Characters(Start:=26, Length:=6).Font.Color = rouge
      c.Characters(Start:=26, Length:=6).Font.Bold = True
    ' autres cas
    Case Else:
      c.Value = "En cours": c.Font.Color = vert
      c.Font.Bold = True
  End Select
End If
End Sub