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

[Loic80]

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,

 

[job75]

Bonjour à tous,

Voyez le fichier joint et cette macro :

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+

 

[Loic80]

Merci mais quand je tape BORNES EML ou BORNES PAPIERS rien ne se passe :/

 

[Loic80]

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

 

[job75]

Si je veux rajouter BORNES OMR en gris, gras et souligné comme les autres, comment dois-je procéder ?

Modifiez les Arrays texte et couleur, je vous laisse faire car c'est un bon exercice

 

[Loic80]

OK. Merci pour votre aide.

 

[job75]

Pour tester le fichier du post #16 j'ai copié la plage E17:J19 sur E20:J30016.

Telle quelle la macro s'exécute chez moi en 36 secondes.

En ajoutant Application.ScreenUpdating = False la durée passe à 24 secondes.

 

[Loic80]

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 ?

 

[Loic80]

Le fichier que j'ai joins est un extrait de mon fichier excel, en fait j'ai 12 onglets dans mon classeur et je souhaite que le code soit sur tout les onglets. Merci.

 

[job75]

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 :

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.

 

[Loic80]

Merci job75. Je regarde ça demain. Bonne soirée.

 

[Loic80]

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