macro pour mettre en rouge les caractéres imcompatibles

=REPT(INDEX(Atelier1;COLONNES($H2:H2));NB.SI(Atelier2;INDEX(Atelier1;COLONNES($H2:H2))))

Function doublons(personne As Range, atelier As Range, ateliers As Range, incompatibilités As Range)
 Application.Volatile
 a = Split(atelier, "+")
 b = ateliers
 c = incompatibilités
 For Each k In a
    For i = LBound(b) To UBound(b)
      If InStr(UCase(b(i, 1)), UCase(Trim(k))) > 0 And InStr(UCase(c(i, 1)), UCase(personne)) > 0 Then doublons = True
    Next i
  Next k
End Function

Private Sub CommandButton1_Click() 'Ateliers à éviter
Dim P As Range, c As Range, s1, s2, inc, i, s3, at1, x$, at2
Set P = Range("C2", [C500].End(xlUp)(2))
P.Font.ColorIndex = xlAutomatic 'RAZ
For Each c In P
  If c(1, 2) <> "" Then
    s1 = Split(c(1, 2)) 'incompatibilité
    s2 = Split(c, "+") 'ateliers
    For Each inc In s1
      i = Application.Match(inc, P.Columns(-1), 0)
      If IsNumeric(i) Then
        s3 = Split(P(i), "+") 'ateliers
        For Each at1 In s2
          x = LCase(Trim(at1))
          For Each at2 In s3
            If x = LCase(Trim(at2)) Then
              c.Characters(InStr(c, x), Len(x)).Font.ColorIndex = 3
              P(i).Characters(InStr(P(i), x), Len(x)).Font.ColorIndex = 3
            End If
          Next at2
        Next at1
      End If
    Next inc
  End If
Next c
End Sub

Function doublons(personne As Range, atelier As Range, ateliers As Range, personnes As Range, incompatibilités As Range)
 Application.Volatile
 a = Split(atelier, "+")
 b = ateliers
 c = incompatibilités
 d = personnes
 For Each k In a
    For i = LBound(b) To UBound(b)
      If InStr(UCase(b(i, 1)), UCase(Trim(k))) > 0 Then
         For j = LBound(c) To UBound(c)
           If (personne = Trim(c(j, 1)) And Trim(c(j, 2)) = d(i, 1)) Or (personne = Trim(c(j, 2)) And Trim(c(j, 1)) = d(i, 1)) Then doublons = True
         Next j
      End If
    Next i
  Next k
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Incomp As Range, P As Range, c As Range, i, j, s1, s2, at1, x$, at2
Set Incomp = [A16].CurrentRegion 'à adapter
Set P = [A1].CurrentRegion.Offset(1)
If Intersect(Target, Union(Incomp, P)) Is Nothing Then Exit Sub
P.Columns(3).Font.ColorIndex = xlAutomatic 'RAZ
For Each c In Incomp.Columns(1).Cells
  i = Application.Match(Trim(c), P.Columns(1), 0)
  j = Application.Match(Trim(c(, 2)), P.Columns(1), 0)
  If IsNumeric(i) And IsNumeric(j) Then
    s1 = Split(P(i, 3), "+")
    s2 = Split(P(j, 3), "+")
    For Each at1 In s1
      x = LCase(Trim(at1))
      For Each at2 In s2
        If x = LCase(Trim(at2)) Then
          P(i, 3).Characters(InStr(P(i, 3), x), Len(x)).Font.ColorIndex = 3
          P(j, 3).Characters(InStr(P(j, 3), x), Len(x)).Font.ColorIndex = 3
          Exit For
        End If
      Next at2
    Next at1
  End If
Next c
End Sub

Private Sub CommandButton1_Click() 'Effacer les couleurs
[A1].CurrentRegion.Columns(3).Offset(1).Font.ColorIndex = xlAutomatic
End Sub

Private Sub Worksheet_Activate()
'au cas où la plage "Incompa" ait été modifiée
Incompatibilité
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:AD" & Range("A" & Rows.Count).End(xlUp).Row)) _
  Is Nothing Then Incompatibilité
End Sub

Sub Incompatibilité()
Dim Incomp As Range, P As Range, c As Range, r As Range
Dim deb As Range, i, col, j, s1, s2, at1, x$, at2
Set Incomp = [Incompa]
Set P = Range("A1:AD" & Range("A" & Rows.Count).End(xlUp).Row)
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les événements
On Error Resume Next 'sécurité
'---RAZ des formats des plages "Nom"---
For Each c In [A4,D4,G4,J4,M4,P4,S4,V4,Y4,AB4]
  c.AutoFill c.Resize(P.Rows.Count - 3), xlFillFormats
Next
'---recherche des incompatibilités---
For Each c In Incomp.Columns(1).Cells
  If c <> "" And c(, 2) <> "" Then
    Set r = P.Find(Trim(c), , xlValues, xlWhole)
    If Not r Is Nothing Then
      Set deb = r 'mémorise la 1ère cellule
      Do
        i = r.Row: col = r.Column
        j = Application.Match(Trim(c(, 2)), P.Columns(col), 0)
        If IsNumeric(j) Then
          s1 = Split(P(i, col + 2), "+")
          s2 = Split(P(j, col + 2), "+")
          For Each at1 In s1
            x = LCase(Trim(at1))
            For Each at2 In s2
              If x = LCase(Trim(at2)) Then
                Union(P(i, col), P(j, col)).Interior.ColorIndex = 1 'noir
                Union(P(i, col), P(j, col)).Font.ColorIndex = 2 'blanc
                Exit For
              End If
            Next at2
          Next at1
        End If
        Set r = P.Find(r, r) 'recherche suivante
      Loop While r.Address <> deb.Address
    End If
  End If
Next c
Application.EnableEvents = True 'réactive les événements
End Sub

Sub Incompatibilité()
Dim Incomp As Range, P As Range, PR As Range, c As Range
Dim r As Range, deb As Range, i, col, j, s1, s2, at1, x$, at2
Set Incomp = [Incompa]
Set P = Range("A1:AD" & Range("A" & Rows.Count).End(xlUp).Row)
If P.Rows.Count < 5 Then Exit Sub 'sécurité
Application.ScreenUpdating = False
'---RAZ des formats des plages "Nom" et définition de PR---
Application.EnableEvents = False 'désactive les événements
Set PR = [A5]
For Each c In [A4,D4,G4,J4,M4,P4,S4,V4,Y4,AB4]
  c.AutoFill c.Resize(P.Rows.Count - 3), xlFillFormats
  Set PR = Union(PR, c(2).Resize(P.Rows.Count - 4))
Next
Application.EnableEvents = True 'réactive les événements
'---recherche des incompatibilités---
For Each c In Incomp.Columns(1).Cells
  If c <> "" And c(, 2) <> "" Then
    Set r = PR.Find(Trim(c), , xlValues, xlWhole, xlByColumns)
    If Not r Is Nothing Then
      Set deb = r 'mémorise la 1ère cellule
      Do
        i = r.Row: col = r.Column
        j = Application.Match(Trim(c(, 2)), P.Columns(col), 0)
        If IsNumeric(j) Then
          s1 = Split(P(i, col + 2), "+")
          s2 = Split(P(j, col + 2), "+")
          For Each at1 In s1
            x = LCase(Trim(at1))
            For Each at2 In s2
              If x = LCase(Trim(at2)) Then
                Union(P(i, col), P(j, col)).Interior.ColorIndex = 1 'noir
                Union(P(i, col), P(j, col)).Font.ColorIndex = 2 'blanc
                Exit For
              End If
            Next at2
          Next at1
        End If
        Set r = PR.Find(r, r) 'recherche suivante
      Loop While r.Address <> deb.Address
    End If
  End If
Next c
End Sub

Private Sub Worksheet_Activate()
'au cas où la plage "Incompa" ait été modifiée
Incompatibilité Cells, True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim plage As Range
Set plage = Intersect(Target, Range("A1:AD" & Range("A" & Rows.Count).End(xlUp).Row))
If Not plage Is Nothing Then Incompatibilité plage, False
End Sub

Sub Incompatibilité(plage As Range, ecran As Boolean)
Dim Incomp As Range, P As Range, PR As Range, c As Range
Dim r As Range, deb As Range, i, col, j, s1, s2, at1, x$, at2
Set Incomp = [Incompa]
Set P = Range("A1:AD" & Range("A" & Rows.Count).End(xlUp).Row)
If P.Rows.Count < 5 Then Exit Sub 'sécurité
If ecran Then Application.ScreenUpdating = False
'---RAZ des formats des plages "Nom" et définition de PR---
Application.EnableEvents = False 'désactive les événements
For Each c In [A4,D4,G4,J4,M4,P4,S4,V4,Y4,AB4]
  If Not Intersect(c.Resize(, 3), plage.EntireColumn) Is Nothing Then
    c.AutoFill c.Resize(P.Rows.Count - 3), xlFillFormats
    Set PR = Union(IIf(PR Is Nothing, c(2), PR), c(2).Resize(P.Rows.Count - 4))
  End If
Next
Application.EnableEvents = True 'réactive les événements
'---recherche des incompatibilités---
For Each c In Incomp.Columns(1).Cells
  If c <> "" And c(, 2) <> "" Then
    Set r = PR.Find(Trim(c), , xlValues, xlWhole, xlByColumns)
    If Not r Is Nothing Then
      Set deb = r 'mémorise la 1ère cellule
      Do
        i = r.Row: col = r.Column
        j = Application.Match(Trim(c(, 2)), P.Columns(col), 0)
        If IsNumeric(j) Then
          s1 = Split(P(i, col + 2), "+")
          s2 = Split(P(j, col + 2), "+")
          For Each at1 In s1
            x = LCase(Trim(at1))
            For Each at2 In s2
              If x = LCase(Trim(at2)) Then
                Union(P(i, col), P(j, col)).Interior.ColorIndex = 1 'noir
                Union(P(i, col), P(j, col)).Font.ColorIndex = 2 'blanc
                Exit For
              End If
            Next at2
          Next at1
        End If
        Set r = PR.Find(r, r) 'recherche suivante
      Loop While r.Address <> deb.Address
    End If
  End If
Next c
End Sub