Sub Couleurs()
Dim voyelle$, d As Object, c As Range, i%, flag As Boolean, coul
voyelle = "AEIOUY"
Set d = CreateObject("Scripting.Dictionary")
Randomize
With Application
.ScreenUpdating = False
.DisplayAlerts = False
For Each c In [A1].CurrentRegion
For i = 1 To Len(c)
If Mid(c, i, 1) = " " Then d.RemoveAll: i = i + 1 'nouveau mot
flag = True
If InStr(voyelle, UCase(Mid(c, i, 1))) Then If i > 1 Then If Mid(c, i - 1, 1) <> " " Then flag = False
If flag Then
Do
coul = .RandBetween(3, 56) 'palette des 56 couleurs
Loop While d.exists(coul)
d(coul) = ""
End If
c.Characters(i, 1).Font.ColorIndex = coul
Next i, c
End With
End Sub