Private Sub Worksheet_Change(ByVal Target As Range)
Dim w$, x$, y$, z$, r As Range, d As Object, P As Range
w = "Unknow": x = "Navy": y = "Marines": z = ",O-11,O-10,O-9,"
Application.ScreenUpdating = False
'---polices en colonnes B:K---
Set r = Intersect(Target, [B:C,F:G,I:K], UsedRange) 'en colonnes D E H il y a des formules
If Not r Is Nothing Then
r.Font.ColorIndex = xlAutomatic 'RAZ
For Each r In r
If r = w Then r.Font.Color = vbRed
Next
End If
Set r = Intersect(Target, [A:A], UsedRange)
If Not r Is Nothing Then
Intersect(r.EntireRow, [D:E]).Font.ColorIndex = xlNone 'RAZ
For Each r In r
If r(1, 4) = w Then r(1, 4).Font.Color = vbRed 'colonne D
If r(1, 5) = w Then r(1, 5).Font.Color = vbRed 'colonne E
Next
End If
'---colonnes F et G---
Set P = Intersect(Target, [F:G], UsedRange)
If Not P Is Nothing Then
Intersect(P.EntireRow, [B:K]).Interior.ColorIndex = xlNone 'RAZ
For Each r In Intersect(P.EntireRow, [F:G]).Rows
If InStr(z, "," & r.Cells(2) & ",") Then
If r.Cells(1) = x Then
Intersect(r.EntireRow, [B:K]).Interior.Color = vbCyan
ElseIf r.Cells(1) = y Then
Intersect(r.EntireRow, [B:K]).Interior.Color = vbYellow
End If
End If
Next
For Each r In Intersect(P.EntireRow, [A:A]) 'couleurs en colonne A
If r.Interior.Color <> vbRed Then r.Interior.Color = r(1, 2).Interior.Color
Next
End If
'---doublons en colonne A---
Set r = Intersect(Target, [A:A], UsedRange)
If Not r Is Nothing Then
Set r = Intersect(Range("A2:A" & Rows.Count), UsedRange)
r.Interior.ColorIndex = xlNone 'RAZ
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each r In r
If d.exists(r.Value) Then
Union(Cells(d(r.Value), 1), r).Interior.Color = vbRed
Else
If r <> "" Then d(r.Value) = r.Row 'mémorise la ligne
If r(1, 2).Interior.ColorIndex <> xlNone Then r.Interior.Color = r(1, 2).Interior.Color 'si la ligne est colorée
End If
Next
End If
End Sub