XL 2016 Mise en couleur cellule par rapport à une autre cellule.

Option Explicit
Private AncIndice As Long, Posit() As Long, Cible As Interior, Couleur As Long, ÇaTourne As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim TNum(1 To 10, 1 To 1) As Long, N As Long, P As Long
   If AncIndice > 0 Then
      For N = 1 To 10: TNum(Posit(N), 1) = N: Next N
      N = Target.Value
      TNum(Posit(AncIndice), 1) = N: TNum(Posit(N), 1) = AncIndice
      Application.EnableEvents = False
      Me.[D2:D11].Value = TNum
      Application.EnableEvents = True
      End If
   ChangerLesCouleurs
   End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Dim TNum(), L As Long
   If Intersect(Me.[D2:D11], Target) Is Nothing Then
      ÇaTourne = False: AncIndice = 0
   Else
      TNum = Me.[D2:D11].Value: ReDim Posit(1 To 10): AncIndice = Target.Value
      For L = 1 To 10: Posit(TNum(L, 1)) = L: Next L
      Set Cible = Target.Interior: Couleur = Cible.Color
      If ÇaTourne Then Exit Sub
      ÇaTourne = True
      While ÇaTourne: DoEvents
         If Cible.Color <> Couleur Then
            Couleur = Cible.Color: ChangerLesCouleurs: End If: Wend: End If
   End Sub
Sub ChangerLesCouleurs()
   Dim Rng As Range, TCoul(1 To 10), Cel As Range
   Set Rng = Range("D2:D11")
   For Each Cel In Rng
      TCoul(Cel.Value) = Cel.Interior.Color
      Next Cel
   Set Rng = Range("G2:Q11")
   For Each Cel In Rng
      Cel.Interior.Color = TCoul(Cel.Value)
      Next Cel
   End Sub

 While ÇaTourne: DoEvents
         If Cible.Color <> Couleur Then
            Couleur = Cible.Color: ChangerLesCouleurs: End If: Wend: End If

Option Explicit
Private WithEvents Cmbrs As CommandBars    'creation de l'object commandbars events
Public p As Range
Public tbl
'evenement commandbars
Private Sub Cmbrs_OnUpdate()
    Dim i&
    Application.CommandBars.FindControl(ID:=2040).Enabled = Not Application.CommandBars.FindControl(ID:=2040).Enabled
    For i = 1 To UBound(tbl)
        If tbl(i, 1) <> p.Cells(i).Interior.Color Or tbl(i, 2) <> p.Cells(i).Value Then quelquechose_en_D2_D11_Change (i)
    Next
End Sub

'evenement pipopipo quelquechose_en_D2_D11_Change de la plage D2:D11
Private Sub quelquechose_en_D2_D11_Change(theRow)
    Dim cel As Range, i&
    tbl(theRow, 1) = p.Cells(theRow).Interior.Color
    For Each cel In Feuil1.Range("G2:Q11").Cells
        If cel.Value = tbl(theRow, 2) Then cel.Interior.Color = xlNone 'on enleve la couleur
    Next
    tbl(theRow, 2) = IIf(p.Cells(theRow) = "", "|", p.Cells(theRow).Value) 'pour ne pas confondre le 0 et le vide
    For Each cel In Feuil1.Range("G2:Q11").Cells
        If cel.Value = tbl(theRow, 2) Then cel.Interior.Color = tbl(theRow, 1) 'on remet la couleur
    Next
End Sub



Private Sub Workbook_Open()
    Dim i&
    Set p = Feuil1.[D2:D11]
    ReDim tbl(1 To p.Cells.Count, 1 To 2)
    For i = 1 To UBound(tbl): tbl(i, 1) = p.Cells(i).Interior.Color: tbl(i, 2) = p.Cells(i).Value: Next
     Set Cmbrs = Application.CommandBars
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Column = 4 And Target.Count = 1 Then
 If Target.Value <> Empty Then If Application.CountIf([D2:D11], Target.Value) > 1 Then Application.Undo
End If
End Sub