Comment afficher plusieurs polices dans une cellule ?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rech As Range, c As Range
If Target.Address = "$A$8" Then 'Si A8 est modifiée
  Set Rech = Range("A12:A" & Range("A65536").End(xlUp))  'On cherche le code dans la colonne A
  Set c = Rech.Find(what:=Target.Value, LookIn:=xlValues, lookat:=xlWhole)
  If Not c Is Nothing Then 'Si on l'a trouvé
    [D2] = c(1, 4)  'On recopie la texte brut en D2
    For t = 1 To Len(c(1, 4))  'Puis pour chaque caractère
      [D2].Characters(t, 1).Font.Name = c(1, 4).Characters(t, 1).Font.Name 'on applique le bon nom de police
    Next
   End If
End If
End Sub