Option Explicit
Public TabCouleursCaractèresCellule() As Variant '1 - Start, 2 - Length , 3 - Color
'------------------------------------------------------------------------------
'Place en TabCouleursCaractèresCellule les couleurs de caractères d'une cellule
'Après exécution:
'Il y a Ubound(TabCouleursCaractèresCellule, 2) couleurs de caractères
'Chaque couleur d'indice i:
'Commence (Start) en TabCouleursCaractèresCellule(1, i)
'Longueur (Length) en TabCouleursCaractèresCellule(2, i)
'Couleur(Color) en TabCouleursCaractèresCellule(3, i)
'------------------------------------------------------------------------------
Sub GetColors(ByVal Cellule As Range)
Dim i As Integer
Dim Couleur As Long
Dim Length As Integer
Dim NbCouleurs As Integer
Erase TabCouleursCaractèresCellule
NbCouleurs = 0
Couleur = -1
Set Cellule = Cellule.Cells(1)
If Not VarType(Cellule) = vbString Then Exit Sub
If Len(Cellule.Value) = 0 Then Exit Sub
With Cellule
For i = 1 To Len(.Value)
If .Characters(Start:=i, Length:=1).Font.Color <> Couleur Then
Couleur = .Characters(Start:=i, Length:=1).Font.Color
'Length de la couleur précédente
If NbCouleurs > 0 Then TabCouleursCaractèresCellule(2, NbCouleurs) = i - TabCouleursCaractèresCellule(1, NbCouleurs)
'Nouvelle couleurs
NbCouleurs = NbCouleurs + 1
ReDim Preserve TabCouleursCaractèresCellule(1 To 3, NbCouleurs)
TabCouleursCaractèresCellule(1, NbCouleurs) = i
TabCouleursCaractèresCellule(3, NbCouleurs) = Couleur
End If
Next i
'Length de la dernière couleur
TabCouleursCaractèresCellule(2, NbCouleurs) = i - TabCouleursCaractèresCellule(1, NbCouleurs)
End With
End Sub
'------------------------------------------------------------------------------
'Place les couleurs de caractères TabCouleursCaractèresCellule dans une cellule
'------------------------------------------------------------------------------
Sub SetColors(ByVal Cellule As Range)
Dim i As Integer
If Not (Not TabCouleursCaractèresCellule) Then
'OK
Else
'MsgBox "La fonction SetColors exécutée sans GetColors préalable sur cellule de type texte non vide"
Exit Sub
End If
Set Cellule = Cellule.Cells(1)
If Not VarType(Cellule) = vbString Then Exit Sub
With Cellule
For i = 1 To UBound(TabCouleursCaractèresCellule, 2)
.Characters(Start:=TabCouleursCaractèresCellule(1, i), _
Length:=TabCouleursCaractèresCellule(2, i)) _
.Font.Color = TabCouleursCaractèresCellule(3, i)
Next i
End With
End Sub