Sub Coloriser()
Dim tref, trans&, col&, der&, t, i&, k&
tref = Me.ListObjects("lsoCouleurs").DataBodyRange
For i = 1 To UBound(tref):
tref(i, 1) = Application.Trim(Replace(tref(i, 1), Chr(160), " "))
tref(i, 2) = Mid(tref(i, 1), 3)
If Trim(tref(i, 2)) = "" Then tref(i, 2) = "" Else tref(i, 2) = " " & tref(i, 2) & " "
tref(i, 1) = Trim(Left(tref(i, 1), 2))
Next i
trans = Range("lsoCouleurs").Row - 1
col = Range("lsoCouleurs").Column + 1
If Me.FilterMode Then Me.ShowAllData
der = Cells(Rows.Count, "j").End(xlUp).Row
t = Range("j1:k1").Resize(der)
Application.ScreenUpdating = False
Range("i2:i" & Rows.Count).Interior.ColorIndex = xlColorIndexNone
For i = 5 To UBound(t)
If Not IsError(t(i, 1)) Then
t(i, 1) = Application.Trim(Replace(t(i, 1), Chr(160), " ")): t(i, 2) = Application.Trim(Replace(t(i, 2), Chr(160), " "))
For k = 1 To UBound(tref)
If tref(k, 1) Like t(i, 1) & "*" Then
If tref(k, 2) Like "* " & t(i, 2) & " *" Then
Cells(i, "i").Interior.Color = Cells(k + trans, col).Interior.Color
End If
End If
Next k
End If
Next i
End Sub