XL 2016 Colorier une lettre, un mot ou une phrase en entier

[cd95]

Bonjour,

J’ai trouvé la solution à mon premier problème à pouvoir colorier que la lettre ou le mot recherché mais pas les mêmes lettres qui composent ce même mot mais qui sont rattachées à une autre chaîne (voir l’exemple dans la pièce jointe)

Maintenant mon deuxième problème c’est de pouvoir faire la même chose mais avec une phrase en entier car le code fonctionne correctement pour chercher un mot, même une lettre d’ailleurs c’est ce que je veux mais ne fonctionne pas pour une phrase entière (on peut chercher la phrase à partir de son deuxième mot ou le troisième mais pas toute la phrase en entier !!!).

Si je veux chercher « tata et toto vont chercher toto1 à l'école » en entier ça ne fonctionne pas.
Si je veux chercher « et toto vont chercher toto1 à l'école » ça fonctionne correctement.

Pourriez-vous m’aider SVP à résoudre ce problème et merci d’avance.

 

[patricktoulon]

heu
bonjour
tu devrais faire attention a ce que tu fait

 

[cd95]

Mon tableau corrigé. Merci
patricktoulon

 

[cd95]

heu
bonjour
tu devrais faire attention a ce que tu fait
Regarde la pièce jointe 1058558

Merci beaucoup je n'ai pas fait attention (faute de frappe)

 

[patricktoulon]

re

Option Explicit

Sub test()
    colorier Selection, Application.InputBox("Quelle est la chaîne à mettre en évidence:", "Recherche:", , , , , , 2)    '"toto"
End Sub

Sub colorier(xplage As Range, xmot)
    Dim xCell As Range, i&
    Application.ScreenUpdating = False
    xplage.Font.ColorIndex = xlColorIndexAutomatic
    For Each xCell In Selection    'xplage
        For i = 1 To Len(xCell.Text)
            If Mid(" " & xCell.Text & " ", i, Len(xmot) + 2) Like " " & xmot & " " Then
                xCell.Characters(i, Len(xmot)).Font.Color = RGB(255, 0, 0)
            i = i + Len(xmot)
            End If
     Next
    Next
End Sub

 

[cd95]

re

Option Explicit

Sub test()
    colorier Selection, Application.InputBox("Quelle est la chaîne à mettre en évidence:", "Recherche:", , , , , , 2)    '"toto"
End Sub

Sub colorier(xplage As Range, xmot)
    Dim xCell As Range, i&
    Application.ScreenUpdating = False
    xplage.Font.ColorIndex = xlColorIndexAutomatic
    For Each xCell In Selection    'xplage
        For i = 1 To Len(xCell.Text)
            If Mid(" " & xCell.Text & " ", i, Len(xmot) + 2) Like " " & xmot & " " Then
                xCell.Characters(i, Len(xmot)).Font.Color = RGB(255, 0, 0)
            i = i + Len(xmot)
            End If
     Next
    Next
End Sub

Génial ça fonctionne à merveille. Mille merci

Je ne veux pas abuser de votre gentillesse mais pourriez-vous me donner une autre solution pour trouver les mêmes mots même qui sont collés à une virgule ou un point ou un signe quelconque.

(« tata et toto vont chercher toto1 à l'école de toto. »)
(« tata et toto vont chercher toto1 à l'école de toto, »)

J’ai trouvé une solution de genre :

If Right(txt, 1) = "." Or Right(txt, 1) = "," Or Right(txt, 1) = ";" Then txt = Left(txt, Len(txt) - 1)

If Right(txt, 1) = ":" Or Right(txt, 1) = "!" Or Right(txt, 1) = "?" Then txt = Left(txt, Len(txt) - 1)

If Right(txt, 1) = ")" Or Right(txt, 1) = "-" Or Right(txt, 1) = "]" Then txt = Left(txt, Len(txt) - 1)

If Right(txt, 1) = """" Or Right(txt, 1) = "'" Or Right(txt, 1) = "_" Then txt = Left(txt, Len(txt) - 1)

Mais je ne sais pas comment l’intégrer dans le code.

 

[cd95]

Génial ça fonctionne à merveille. Mille merci

Je ne veux pas abuser de votre gentillesse mais pourriez-vous me donner une autre solution pour trouver les mêmes mots même qui sont collés à une virgule ou un point ou un signe quelconque.

(« tata et toto vont chercher toto1 à l'école de toto. »)
(« tata et toto vont chercher toto1 à l'école de toto, »)

J’ai trouvé une solution de genre :

If Right(txt, 1) = "." Or Right(txt, 1) = "," Or Right(txt, 1) = ";" Then txt = Left(txt, Len(txt) - 1)

If Right(txt, 1) = ":" Or Right(txt, 1) = "!" Or Right(txt, 1) = "?" Then txt = Left(txt, Len(txt) - 1)

If Right(txt, 1) = ")" Or Right(txt, 1) = "-" Or Right(txt, 1) = "]" Then txt = Left(txt, Len(txt) - 1)

If Right(txt, 1) = """" Or Right(txt, 1) = "'" Or Right(txt, 1) = "_" Then txt = Left(txt, Len(txt) - 1)

Mais je ne sais pas comment l’intégrer dans le code.

Voici le fichier dont je vous ai parlé

 

[patricktoulon]

re

Option Explicit

Sub test()
    Dim mot_phrase$
    mot_phrase = Application.InputBox("Quelle est la chaîne à mettre en évidence:", "Recherche:", , , , , , 2)
    'appel de la sub
    'colorier Selection , recherche , ce qu'on veut avant , ce  qu'on veut apres
    colorier Selection, mot_phrase, ".", ","
End Sub

Sub colorier(xplage As Range, xmot, Optional devant As String = "", Optional apres As String = "")
    Dim xCell As Range, i&
    If devant = "" Then devant = " "
    If apres = "" Then apres = " "
    Application.ScreenUpdating = False
    xplage.Font.ColorIndex = xlColorIndexAutomatic
    For Each xCell In Selection    'xplage
        For i = 1 To Len(xCell.Text)
            If Mid(devant & xCell.Text & apres, i, Len(xmot)) Like xmot Then
                xCell.Characters(i - 1, Len(xmot) + 1).Font.Color = RGB(255, 0, 0)
                i = i + Len(xmot)
            End If
        Next
    Next
End Sub

 

[cd95]

re

Option Explicit

Sub test()
    Dim mot_phrase$
    mot_phrase = Application.InputBox("Quelle est la chaîne à mettre en évidence:", "Recherche:", , , , , , 2)
    'appel de la sub
    'colorier Selection , recherche , ce qu'on veut avant , ce  qu'on veut apres
    colorier Selection, mot_phrase, ".", ","
End Sub

Sub colorier(xplage As Range, xmot, Optional devant As String = "", Optional apres As String = "")
    Dim xCell As Range, i&
    If devant = "" Then devant = " "
    If apres = "" Then apres = " "
    Application.ScreenUpdating = False
    xplage.Font.ColorIndex = xlColorIndexAutomatic
    For Each xCell In Selection    'xplage
        For i = 1 To Len(xCell.Text)
            If Mid(devant & xCell.Text & apres, i, Len(xmot)) Like xmot Then
                xCell.Characters(i - 1, Len(xmot) + 1).Font.Color = RGB(255, 0, 0)
                i = i + Len(xmot)
            End If
        Next
    Next
End Sub

Merci pour votre effort mais ce n’est pas exactement ce que je voulais. Je vous ai envoyé un fichier 2mn avant que vous m’envoyer le vôtre. En fait je veux la même chose mais dans une Application.InputBox.

 

[cd95]

re

Option Explicit

Sub test()
    Dim mot_phrase$
    mot_phrase = Application.InputBox("Quelle est la chaîne à mettre en évidence:", "Recherche:", , , , , , 2)
    'appel de la sub
    'colorier Selection , recherche , ce qu'on veut avant , ce  qu'on veut apres
    colorier Selection, mot_phrase, ".", ","
End Sub

Sub colorier(xplage As Range, xmot, Optional devant As String = "", Optional apres As String = "")
    Dim xCell As Range, i&
    If devant = "" Then devant = " "
    If apres = "" Then apres = " "
    Application.ScreenUpdating = False
    xplage.Font.ColorIndex = xlColorIndexAutomatic
    For Each xCell In Selection    'xplage
        For i = 1 To Len(xCell.Text)
            If Mid(devant & xCell.Text & apres, i, Len(xmot)) Like xmot Then
                xCell.Characters(i - 1, Len(xmot) + 1).Font.Color = RGB(255, 0, 0)
                i = i + Len(xmot)
            End If
        Next
    Next
End Sub

En fait votre premier tableau ça me va à merveille est c’est la solution idéale. Juste si on peut rajouter l’option que je vous ai demandé à savoir colorier les mêmes mots recherchés mais qui sont collés à un point à la fin d’une phrase ou collés à une virgule au milieu d’une autre phrase. (voir en dessous le résultat attendu en gras si je cherche que le mot: toto)

(« tata et toto vont chercher toto1 à l'école de toto. »)

(« tata et toto, vont chercher toto1 à l'école de toto. »)