XL 2019 Changement couleur police avec cellules fusionnées

[Jacques25bis]

Bonjour à tous,

Après quelques recherche j'ai réussi à faire un code pour le changement de couleur des caractères de mes cellules :

Private Sub CommandButton1_Click()
Dim r As Range
For Each r In Range("A10:A15")
Longueur = Len(r)
For j = 1 To Longueur
If r.Characters(Start:=j, Length:=1).Font.Color = 255 Then 'rouge
r.Characters(Start:=j, Length:=1).Font.Color = 8696052 'rouge clair
Else
r.Characters(Start:=j, Length:=1).Font.Color = 14395790 'bleu clair
End If
Next j
Next r
End Sub

Ca ne marche pas sur l'ensemble de mes cellules, sur la première cellule (A10) il me change bien le 1er caractère mais les autres passent en bleu clair. Idem pour la 3ème cellule (A13)
Je pensai que ça venant de la fusion des cellules mais à priori non.

Je vous joins un fichier avec le code et les données colorées (en double pour les essais)

Merci de votre aide.

@ plus

Jack

 

[Jacques25bis]

Re-Bonjour,

J'essaye dans tous les sens mais je n'arrive à rien (cellules fusionnées ou pas) à priori quand la couleur au début du texte est rouge il ne fait que la 1ère lettre, sinon si la première lettre est bleu tout se passe bien... J'en perd mon latin...
J'ai essayé d'inscrire le code couleur de tous les caractères dans des cellules en colonne ça fonctionne
J'ai essayé avec .color et .colorindex le résultat est le même.

Si toutefois vous y comprenez qqchose je suis tout ouïe

@ plus

Jack

 

[Dranreb]

Bonjour
Peut être auriez vous oublié que si un caractère est devenu rouge pâle il n'est plus rouge et passe donc en bleu ?

 

[Jacques25bis]

Bonjour Dranreb,

Pourquoi quand la 1ère lettre est bleu ça marche correctement quelque soit les couleurs derrières?
Comment puis-je corriger si ça vient de cet oubli?

Merci

Jack

 

[Dranreb]

Essayez comme ça :

Private Sub CommandButton1_Click()
   Dim Cel As Range, P As Integer, R As Byte, B As Byte
   For Each Cel In Range("A10:A15")
      For P = 1 To Len(Cel.Value)
         With Cel.Characters(Start:=P, Length:=1).Font
            R = .Color And &HFF: B = .Color \ &H10000
            .Color = IIf(R > B, &H547FFF, &HFFAE81)
            End With
         Next P, Cel
   End Sub

 

[Jacques25bis]

Re,

Ca me donne le même résultat...

 

[Dranreb]

Joignez le classeur modifié, parce que chez moi ça marche.

 

[Jacques25bis]

Le voici

 

[Dranreb]

Effectivement ça ne marche plus avec vos données.
On dirait que le changement de couleur du 1er caractère change la couleur de toute la cellule.
Alors on va changer de stratégie :

Private Sub CommandButton1_Click()
   Dim Cel As Range, P As Integer, TCoul() As Long, R As Byte, B As Byte
   For Each Cel In Range("A10:A15")
      ReDim TCoul(0 To Len(Cel.Value))
      For P = 1 To Len(Cel.Value)
         With Cel.Characters(Start:=P, Length:=1).Font
            R = .Color And &HFF: B = .Color \ &H10000
            TCoul(P) = IIf(R > B, &H547FFF, &HFFAE81)
            End With
         Next P
      For P = 1 To Len(Cel.Value)
         Cel.Characters(Start:=P, Length:=1).Font.Color = TCoul(P)
         Next P, Cel
   End Sub

 

[Jacques25bis]

Ca parfait ça marche nickel, je vais éplucher le code pour le comprendre, en attendant un grand merci, j'ai passé quelques heures dessus...

Bon week end.

Jack