Mettre en couleur un mot recherché quelque soit la casse

[scoobytor]

Bonjour à tous,

Je cherche à mettre en évidence un mot dans différentes cellules (je veux colorier que le mot pas la cellule).

J'ai trouvé un code VBA qui marche très bien(merci à l'auteur j'ai laissé son nom dans le code) , mon seul souci est que le mot cherché doit être tapé dans VBA alors que j'aimerais qu'il corresponde au mot contenu dans la cellule B2 de ma feuille TEST.

Je joins un fichier exemple et voici le code VBA:

Sub TestCharacterColor()
Const SheetName As String = "TEST" ' Nom de la feuille où se trouve les textes à mettre en forme
Const RangeAddress As String = "B4:M40" ' Plage de cellules où se trouve les textes à mettre en forme

Const WordList As String = "cheval" ' Liste des mots qui doivent être mis en évidence

'c'est cette partie que je veux changer, il faut que Wordlist soit le mot contenu dans la cellule B2 de ma feuille TEST

Dim rng As Range
Set rng = ThisWorkbook.Worksheets(SheetName).Range(RangeAddress)
CharacterColor rng, WordList
End Sub

Sub CharacterColor(AreaText As Range, TextColoring As String, Optional RGBCode As Long = vbRed, Optional ResetColor As Boolean = True)
' Procédure de mise en évidence des mots dans une plage de cellules
' Author : http://Philippe.Tulliez.be
' Date : 15/12/2015
' Version : 1.1
' Arguments
' AreaText (Range) Plage de cellules à l'intérieure de laquelle les mots seront mis en évidence
' TextColoring (String) Liste des mots séparés par un ';' à mettre en évidence
' [RGBCode] (Numérique) Code (RGB) de la couleur qui mettra les mots en évidence (d:vbRed (rouge))
' [ResetColor] (Boolean) Efface la couleur de la plage AreaTexte (d:True)
Dim Cel As Range, nbWord As Integer, tbl() As String, Start As Integer
If ResetColor Then AreaText.Font.Color = 0 ' Efface la mise en forme précédente
TextColoring = LCase(TextColoring)
tbl = Split(TextColoring, ";")
For Each Cel In AreaText
For nbWord = 0 To UBound(tbl)
Start = InStr(LCase(Cel), tbl(nbWord))
Do While Start
Cel.Characters(Start, Len(tbl(nbWord))).Font.Color = RGBCode
Start = InStr(Start + 1, LCase(Cel), tbl(nbWord))
Loop
Next
Next
End Sub

Apparemment Worlist est une constante et lui mettre Wordlist= Range ("B2").value n'a pas marché.

Merci d'avance pour votre aide.

 

[GALOUGALOU]

bonjour scoobytor bonjour le forum
basiquement sans vba
avec une simple formule dans la MFC
=CHERCHE($P$5;B4)
$P$5 la ou se trouve la valeur de recherche cellule figé par $
b4 le début de la zone de recherche
la fonction cherche est insensible à la casse et cherche le mot dans une phrase
cordialement
galougalou

 

[patricktoulon]

bonsoir

Sub test()
    Dim plage As Range, mot$
    Set plage = [B4:M40]
    mot = InputBox("tapez le mot recherché", "mot à colorier")
    If mot <> "" Then rouletambourg plage, mot
End Sub
Sub rouletambourg(plage As Range, mot As String)
    Dim cel As Range, i&
    For Each cel In plage.Cells
        If cel.Value <> "" Then
            If LCase(cel.Text) Like "*" & LCase(mot) & "*" Then
                For i = 1 To Len(cel.Value)
                    If Mid(LCase(cel.Value), i, Len(mot)) = mot Then cel.Characters(i, Len(mot)).Font.Color = vbRed
                Next
            End If
        End If
    Next
End Sub

 

[scoobytor]

Merci GALOUGALOU,

La mise en forme conditionnelle met le fond de la cellule en couleur, moi c'est uniquement le mot cherché qui doit changer de couleur.
Si je cherche CANARD, dans la phrase "il était une fois un canard" seul canard doit changer de couleur, ni le fond de couleur de la cellule. (quelque soit l'orthographe de canard, Canard, CANard, CanArD,canaRD, etc...)

Peut-être une autre solution ?

 

[scoobytor]

Merci patricktoulon,

J'ai testé votre code, le petit souci est que les textes cherchés restent en rouge, donc si je cherche canard puis après cheval, CANARD et CHEVAL est en rouge.

J'ai essayé de rajouter dans la macro test :

plage.Font.Color = 0 ' Efface la mise en forme précedente

pour la couleur cela fonctionne mais la recherche ne donne pas tout le temps le bon résultat si je tape CA, cela reste noir

Une idée ? (nouveau fichier joins)

Merci d'avance.

 

[patricktoulon]

allez soyons fous je t'offre la selection de couleur de ton choix
et
soit la possibilité de ne laisser que les mots correspondant en couleur a chaque fois
soit faire de ta plage un vrai sapin de noël en bloquant simplement le ",true"
question couleurs tu en aura assez ????

Sub test()
    Dim plage As Range, mot$, couleur As Long
    Set plage = [B4:M40]
    mot = InputBox("tapez le mot recherché", "mot à colorier")
    If mot <> "" Then
        If Application.Dialogs(xlDialogEditColor).Show(2, 255, 0, 0) = True Then
            couleur = ActiveWorkbook.Colors(2)
        End If
        ActiveWorkbook.ResetColors
        'si tu debloque le true tu enleveles couleurs precedentes dans les autres mots
        rouletambourg plage, mot, couleur    ', True
    End If
End Sub
Sub rouletambourg(plage As Range, mot As String, Optional couleur As Long = vbRed, Optional razcouleur As Boolean = False)
    Dim cel As Range, i&
    If razcouleur Then plage.Font.Color = vbBlack
    For Each cel In plage.Cells
        If cel.Value <> "" Then
            If LCase(cel.Text) Like "*" & LCase(mot) & "*" Then
                For i = 1 To Len(cel.Value)
                    If Mid(LCase(cel.Value), i, Len(mot)) = LCase(mot) Then cel.Characters(i, Len(mot)).Font.Color = couleur
                Next
            End If
        End If
    Next
End Sub

 

[scoobytor]

And the Winner is patricktoulon.

Parfait, 20/20, 100% ce que je cherchais à faire.

Un grand merci à vous. Mon problème est résolu grâce à vous.

 

[patricktoulon]

de rien pas de soucis ça me détends de faire des trucs comme ca
si tout est OK pointe ton post comme résolu

 

[GALOUGALOU]

bonjour le forum
je plaide coupable
c'est la macro de particktoulon (the best) que je me suis servi
j'ai adapté en supprimant la boite de dialogue
les modification a effectuées pour adapter la cellule de reference et la couleur d'écriture en gras
cordialement
galougalou (et je répète surtout merci à particktoulon
Sub test()
Dim Plage As Range, mot$
Set Plage = [B4:M40]
mot = Range(" P3")
If mot <> "" Then rouletambourgRED Plage, mot

Sub rouletambourgRED(Plage As Range, mot As String)
Dim cel As Range, i&
For Each cel In Plage.Cells
If cel.Value <> "" Then
If LCase(cel.Text) Like "*" & LCase(mot) & "*" Then
For i = 1 To Len(cel.Value)
If Mid(LCase(cel.Value), i, Len(mot)) = mot Then cel.Characters(i, Len(mot)).Font.Color = vbRed

 

[patricktoulon]

re
@GALOUGALOU
1° If Mid(LCase(cel.Value), i, Len(mot)) = lcase(mot)
2° coquille dans "mot = Range(" P3") " 'l'espace dans l'address
sécurité au cas ou touche maj activé
cela dit pourquoi ne pas faire ca alors

Sub test()
    Dim Plage As Range, mot$
    Set Plage = [B4:M40]
    mot = Range("P3")
    If mot <> "" Then rouletambourg Plage, mot, vbGreen
    'ou
    'If mot <> "" Then rouletambourg Plage, mot ' ca sera rouge par defaut
End Sub



Sub rouletambourg(Plage As Range, mot As String, Optional couleur As Long = vbRed)
    Dim cel As Range, i&
    For Each cel In Plage.Cells
        If cel.Value <> "" Then
            If LCase(cel.Text) Like "*" & LCase(mot) & "*" Then
                For i = 1 To Len(cel.Value)
                    If Mid(LCase(cel.Value), i, Len(mot)) = LCase(mot) Then cel.Characters(i, Len(mot)).Font.Color = couleur
                Next
            End If
        End If
    Next
End Sub

demain tu veux une autre couleur, avec la même sub tu peux le faire

 

[GALOUGALOU]

yes c'est mieux !!
@+