XL 2019 Couleur texte en VBA

[GDINFO]

Bonjour

Je cherche depuis un moment une solution

ActiveCell = ActiveCell + "RJEd "
ActiveCell = ActiveCell + "RJEi "



Dans mes codes VBA je voudrais que mon texte RJEd soit ecrit en Rouge et RJEi Bleu et mode Gras

est ce possible ?

merci de votre science et aide

 

[Dudu2]

NON !

 

[Dudu2]

Tant que tu ne décriras pas:
- ce qu'il faut faire pour reproduire le problème
- où est le problème
On n'y arrivera pas.

 

[Dudu2]

NON !

 

[Dudu2]

Bon, j'arrête de jouer aux devinettes.

 

[GDINFO]

faut mettre plusieur que 2 a partir du 3 emem

 

[GDINFO]

Bon, j'arrête de jouer aux devinettes.

Ok merci quand meme , je vais rester avec une couleur

 

[Dudu2]

faut mettre plusieur que 2 a partir du 3 emem

Je ne veux pas te blâmer ou quoi que ce soit, mais est-ce que tu te rends compte que cette phrase ne veut absolument rien dire ?

Je vais supposer (mais supposer seulement) que le problème viendrait du fait qu'on clique plusieurs fois sur des boutons différents dans la même cellule ce qui donnerait ceci, c'est à a dire perte des couleurs précédentes, ce dont tu te plains;

Alors les choses sont plus compliquées car il faut capter puis remettre les couleurs.

Sub a()
    Const RJEd = "RJEd "
 
    Call GetColors(ActiveCell)
    ActiveCell.Value = ActiveCell.Value + RJEd
    Call SetColors(ActiveCell)
    ActiveCell.Characters(Start:=Len(ActiveCell.Value) - Len(RJEd) + 1, Length:=Len(RJEd)).Font.ColorIndex = 3
End Sub

 

[GDINFO]

Bon, j'arrête de jouer aux devinettes.

Mille excuses , je n'ai pas été très clair .

 

[GDINFO]

Je ne veux pas te blâmer ou quoi que ce soit, mais est-ce que tu te rends compte que cette phrase ne veut absolument rien dire ?

Je vais supposer (mais supposer seulement) que le problème viendrait du fait qu'on cliques plusieurs fois sur des boutons différents dans la même cellule/


Sinon pour conserver les couleurs pré

C'est cela
Je n'ai pas été tres clair dans ma demande, effectivement si il y a que 2 RDV ca fonctionne si le 3 eme RDEV les couleurs changent , je dois pouvoir saisir jusqu'a 4 RDV par cellule .

Mes excuses ,

 

[Dudu2]

Les fonctions à placer dans un module indépendant:

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

 

[GDINFO]

Les fonctions à placer dans un module indépendant:

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 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(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 non vide"
        Exit Sub
    End If
   
    Set Cellule = Cellule.Cells(1)
   
    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

Merci de votre retour
Je vais essayer !!!

je vous remercie de votre patience et de votre aide

 

[GDINFO]

Merci de votre retour
Je vais essayer !!!

je vous remercie de votre patience et de votre aide

Merci vraiment pour tout
J'ai enfin compris et cela fonction parfaitement.

Pour mes macros pour boutons vous me conseiller de les sortie du workbooks et de les mètres dans un module séparé ?

Merci

 

[Dudu2]

Les macros qu'on place dans Workbook sont en général seulement celles liées aux évènements Workbook (Open, Close, etc...).
Les macros associées aux boutons Contrôle de Formulaire devraient être dans un module standard, ou plusieurs si tu veux faire une répartition fonctionnelle des boutons dans plusieurs modules que tu peux renommer selon ce que ça fait (ex Module_Test, Module_GetSetColors, Module_MesBoutons, etc...)
Nommer les modules a l'avantage, lorsqu'on a un code important, de mieux s'y retrouver lors de la maintenance.