XL 2016 Mettre en couleur, en gras et souligner un mot d'une phrase dans une cellule

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Loic80

XLDnaute Nouveau
Bonjour,

J'ai un tableau Excel et je souhaite mettre en couleur, en gras et souligner certains mots d'une cellule.
Je m'explique : je voudrai que lorsque j'écris le mot BORNE VERRE, celui-ci soit automatiquement en vert en gras et souligné sur les colonnes E à J, mais je ne sais pas comment faire j'ai cherché sur internet et sur les forums mais malheureusement je n'ai rien trouvé.
Je joins un extrait de mon tableau qui contient l'exemple de ce que je veux faire, je l'ai fait manuellement mais j'aimerai que ce soit automatique surtout parce que ces mots seront répétés sur chaque ligne ou presque, ce qui représente des centaines de lignes.
Je ne sais pas si c'est possible alors j'espère qu'un âme charitable pourra m'indiquer la marche à suivre.
Désolé je débute :/

Merci d'avance.

Cordialement,
 

Pièces jointes

Solution
Bonjour,

La macro fonctionne nickel. Merci job75 pour cette aide précieuse. Je cherchais depuis longtemps comment faire mais c'est du haut niveau et j'ai encore du boulot pour arriver à un résultat comme ça.
J'ai modifier le code pour qu'il commence à la première cellule et ça fonctionne.
Encore une fois merci, mon tableau sera plus lisible comme ça.

Loïc

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range, texte, couleur, i%, j%
Set r = Intersect(Target, Sh.Range("E1:E" & Sh.Rows.Count))
If r Is Nothing Then Exit Sub
texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR")
couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64))
With r.Font...
Bonjour à tous,

Voyez le fichier joint et cette macro :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, texte, couleur, i%, j%
Set r = Intersect(Target, Range("E17:E" & Rows.Count))
If r Is Nothing Then Exit Sub
texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML")
couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0))
With r.Font: .ColorIndex = xlAutomatic: .Bold = False: .Underline = xlNone: End With 'RAZ
For Each r In r 'si entrées multiples (copier-coller)
    For i = 0 To UBound(texte)
        j = InStr(r, texte(i))
        If j Then
            With r.Characters(j, Len(texte(i))).Font
                .Color = couleur(i)
                .Bold = True
                .Underline = xlUnderlineStyleSingle
            End With
        End If
Next i, r
End Sub
A+
 

Pièces jointes

Merci job75, ta macro fonctionne nickel. Si je veux rajouter BORNES OMR en gris, gras et souligné comme les autres, comment dois-je procéder ?
Et dernière question : comment applique ton la macro au classeur complet ?
Merci et après je ne vous embête plus
 

Pièces jointes

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, texte, couleur, i%, j%
Set r = Intersect(Target, Range("E17:E" & Rows.Count))
If r Is Nothing Then Exit Sub
texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR")
couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64))
With r.Font: .ColorIndex = xlAutomatic: .Bold = False: .Underline = xlNone: End With 'RAZ
For Each r In r 'si entrées multiples (copier-coller)
For i = 0 To UBound(texte)
j = InStr(r, texte(i))
If j Then
With r.Characters(j, Len(texte(i))).Font
.Color = couleur(i)
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
End If
Next i, r
End Sub

J'ai réussi à modifier le code pour BORNES OMR en gris mais comment l'applique ton sur tout un classeur différent ?
 
La macro traite les modifications d'un tableau.

Si les tableaux des feuilles sont disposés de la même manière on placera ce code dans ThisWorkBook :
VB:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range, texte, couleur, i%, j%
Set r = Intersect(Target, Sh.Range("E17:E" & Sh.Rows.Count))
If r Is Nothing Then Exit Sub
texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR")
couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64))
With r.Font: .ColorIndex = xlAutomatic: .Bold = False: .Underline = xlNone: End With 'RAZ
For Each r In r 'si entrées multiples (copier-coller)
    For i = 0 To UBound(texte)
        j = InStr(r, texte(i))
        If j Then
            With r.Characters(j, Len(texte(i))).Font
                .Color = couleur(i)
                .Bold = True
                .Underline = xlUnderlineStyleSingle
            End With
        End If
Next i, r
End Sub
Fichier (2), il n'y a plus de macro dans le code de la feuille.
 

Pièces jointes

Bonjour,

La macro fonctionne nickel. Merci job75 pour cette aide précieuse. Je cherchais depuis longtemps comment faire mais c'est du haut niveau et j'ai encore du boulot pour arriver à un résultat comme ça.
J'ai modifier le code pour qu'il commence à la première cellule et ça fonctionne.
Encore une fois merci, mon tableau sera plus lisible comme ça.

Loïc

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range, texte, couleur, i%, j%
Set r = Intersect(Target, Sh.Range("E1:E" & Sh.Rows.Count))
If r Is Nothing Then Exit Sub
texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR")
couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64))
With r.Font: .ColorIndex = xlAutomatic: .Bold = False: .Underline = xlNone: End With 'RAZ
For Each r In r 'si entrées multiples (copier-coller)
For i = 0 To UBound(texte)
j = InStr(r, texte(i))
If j Then
With r.Characters(j, Len(texte(i))).Font
.Color = couleur(i)
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
End If
Next i, r
End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour