Private Sub CommandButton1_Click()
Dim c As Range, txt$, t$, coul$, i%, s
Application.ScreenUpdating = False
For Each c In [B3].CurrentRegion.Offset(1)
txt = c: t = "": coul = ""
For i = 1 To Len(c)
If c.Characters(i, 1).Font.Underline = xlUnderlineStyleNone Then
t = t & Mid(txt, i, 1)
coul = coul & " " & c.Characters(i, 1).Font.Color 'mémorise la couleur
End If
Next i
c = t 'nouveau texte
s = Split(coul)
For i = 1 To Len(c)
c.Characters(i, 1).Font.Color = s(i) 'restitue la couleur
Next i, c
End Sub
Private Sub CommandButton1_Click()
Dim c As Range, txt$, t$, coul$, i%, s, n%
Application.ScreenUpdating = False
For Each c In [B3].CurrentRegion.Offset(1)
txt = c: t = "": coul = ""
For i = 1 To Len(c)
If c.Characters(i, 1).Font.Underline = xlUnderlineStyleNone Then
t = t & Mid(txt, i, 1)
coul = coul & " " & c.Characters(i, 1).Font.Color 'mémorise la couleur
End If
Next i
c = t 'nouveau texte
coul = coul & " " 'un élément (vide) de plus pour s
s = Split(coul)
n = 1
For i = 2 To UBound(s)
If s(i) <> s(i - 1) Then
c.Characters(n, i - n).Font.Color = s(n) 'restitue la couleur par paquet
n = i
End If
Next i, c
End Sub