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

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

  • Classeur1.xlsx
    10.2 KB · Affichages: 24
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...

job75

XLDnaute Barbatruc
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

  • Classeur(1).xlsm
    18.6 KB · Affichages: 12

Loic80

XLDnaute Nouveau
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

  • Classeur(1).xlsm
    17.5 KB · Affichages: 3

Loic80

XLDnaute Nouveau
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 ?
 

job75

XLDnaute Barbatruc
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

  • Classeur(2).xlsm
    19.5 KB · Affichages: 6

Loic80

XLDnaute Nouveau
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
 

Statistiques des forums

Discussions
292 942
Messages
1 927 370
Membres
183 525
dernier inscrit
testapp