Sub MAJ()
Dim d As Object, tablo, couleur&(), i&, coul&, y$, x$, s
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
With Sheets("Feuil1").UsedRange.Columns(3).Resize(, 4) 'colonnes C à F
tablo = .Value 'matrice, plus rapide
ReDim couleur(1 To UBound(tablo))
'---liste sans doublon---
For i = 2 To UBound(tablo)
couleur(i) = .Cells(i, 2).Interior.ColorIndex
coul = couleur(i)
If coul = xlNone Or coul = 2 Then
y = tablo(i, 1) & Chr(1) & tablo(i, 4)
If y <> Chr(1) Then
x = Replace(tablo(i, 2), " ", "") 'supprime les espaces
If InStr(x, ",") Then d(x) = y
End If
End If
Next i
'---remplissage des cellules colorées quand c'est possible---
For i = 2 To UBound(tablo)
coul = couleur(i)
If coul <> xlNone And coul <> 2 Then
x = Replace(tablo(i, 2), " ", "")
If d.exists(x) Then
s = Split(d(x), Chr(1))
tablo(i, 1) = s(0)
tablo(i, 4) = s(1)
End If
End If
Next i
'---restitution---
If .Parent.FilterMode Then .Parent.ShowAllData 'si la feuille est filtrée
.Value = tablo
End With
End Sub