XL 2019 Colorier une lettre, un mot ou une phrase recherchée

[cd95]

Bonjour,

Est-ce que quelqu’un peut m’aider à modifier le code que j’ai trouvé dans le fichier joint qui fait la recherche que pour des mots et moi je veux l’élargir pour rechercher soit une lettre ou un mot isolé comme le permet à ce moment ce code mais rajouter l’option de pouvoir rechercher une phrase entière que ce code ne fait pas. Et surtout traiter les recherche ligne par ligne, copier le résultat de chaque mot ou phrase recherchée dans un nouvel onglet.

Je m’explique mieux : Ce fichier recherche tous les mots de la colonne « A » à la fois moi je veux une procédure qui recherche le premier mot ou la première phrase, copier le résultat dans un nouvel onglet ensuite la procédure se dirige vers la deuxième recherche (ou deuxième ligne) et faire la même chose en série et si possible aussi de nommer chaque onglet par le numéro de la ligne (1 : pour la première ligne de recherche, 2 pour la deuxième ligne et ainsi de suite…).

J’espère que ce n’est pas trop demandé (En option : Onglet « BD » [comme base], onglet : [Liste des mots ou phrase recherchée] et onglet [résultat N°1, résultat N°2, résultat N°3 et ainsi de suite]).

N.B : Il faut rester dans le même thème c.a.d colorier la lettre, la phrase ou le mot entier recherché sans autant colorier les mêmes lettres qui composent ce mot mais qui sont attachés à une autre chaîne.

Exemple N°1 : si je cherche le mot « toto » dans la phrase : (toto veut manger des totomates mais toto est maladetoto). Le résultat doit donner : (toto veut manger des totomates mais toto est maladetoto)

Exemple N°2 : si je cherche la lettre « T » dans la phrase : (Théorème : Xn= T x P et Température = T : 1.35°). Le résultat doit donner : (Théorème : XL= T x P et Température= T : 1.35°).

 

[cd95]

Re @patricktoulon
Ok, Ok

Message pour « mapomme » et « patricktoulon » : pourriez-vous me dire pour mon apprentissage qu’est-ce qu’il aura fallu rajouter au code de mon premier fichier joint pour qu’il accepte la recherche d’une phrase en entier en conservant le même code. Ou est-ce qu’il faut vraiment tous changer ? (J’ai passé du temps fou en vain)

 

[patricktoulon]

re
si tu pare de ce code

Option Explicit

Sub ColorerMot_v4()
Dim p, m, dico, i&, s, n&, j&, deb&, Ti, txt, aSuppr As Boolean, xrg As Range, nbMots, ColonneSupp As Boolean
   Ti = Timer
   Application.ScreenUpdating = False
   Application.StatusBar = "Raz des formats en colonne B..."
   Intersect(UsedRange, Range("b:b")).Font.Bold = False
   Intersect(UsedRange, Range("b:b")).Font.ColorIndex = xlColorIndexAutomatic
   Application.StatusBar = "Lecture des mots et phrases..."
   m = Range("a1:b" & Cells(Rows.Count, "a").End(xlUp).Row)
   p = Range("b1:b" & Cells(Rows.Count, "b").End(xlUp).Row)
   Set dico = CreateObject("scripting.dictionary")
   dico.CompareMode = vbTextCompare
   For i = 1 To UBound(m): dico(m(i, 1)) = "": Next
   Application.StatusBar = "Début de l'analyse et formatage des phrases..."
   For i = 1 To UBound(p)
      aSuppr = True
      s = Split(p(i, 1)): deb = 1
      For j = 0 To UBound(s)
         nbMots = nbMots + 1
         txt = s(j)
         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)
         If dico.Exists(txt) Then
            aSuppr = False
            Cells(i, "b").Characters(Start:=deb, Length:=Len(txt)).Font.Bold = True
            Cells(i, "b").Characters(Start:=deb, Length:=Len(txt)).Font.Color = RGB(0, 0, 255)
         End If
         deb = deb + Len(s(j)) + 1
      Next j
      If aSuppr Then p(i, 1) = CVErr(xlErrNA) Else p(i, 1) = Empty
      If i Mod 500 = 0 Then Application.StatusBar = "Phrase " & i & " / " & UBound(p)
   Next i

   'suppression en masse
   Application.StatusBar = "Suppression en cours -> insertion colonne..."
   On Error GoTo Pas2Colonne
   Columns(3).Insert: ColonneSupp = True
   With Columns(3).Resize(UBound(p))
      Application.StatusBar = "Suppression en cours -> remplissage colonne..."
      .Value = p
      Application.StatusBar = "Suppression en cours -> tri..."
      .Offset(, -1).Resize(, 2).Sort key1:=Cells(1, 3), order1:=xlAscending
      Application.StatusBar = "Suppression en cours -> suppression des lignes..."
      .SpecialCells(xlCellTypeConstants, xlErrors).Offset(, -1).EntireRow.Delete xlShiftUp
      Application.StatusBar = "Suppression en cours -> collage valeurs en colonne A..."
      Range("a1").Resize(UBound(m)) = m
   End With
Pas2Colonne:
   On Error GoTo 0
   If ColonneSupp Then Columns(3).Delete
   Application.StatusBar = False
   MsgBox "C'est terminé! Durée= " & Format(Timer - Ti, "0.0\ sec.") & _
      vbLf & UBound(p) & " phrases traitées contenant " & Format(nbMots, "0,000") & " mots.", vbInformation
End Sub

1 des raisons
tu peux pas faire
s = Split(p(i, 1)): deb = 1
qui coupe par les mot (tout court)par les espaces
et espérer avoir toutes concordances valides avec If Right(txt, 1) = "." Or Righ.......etc..etc....

si tu a
toto mange des bananes a la facon;toto
tu rate le toto 2 ";toto" car ton split
[toto] [mange] [des] [bananes] [a] [la] [facon;toto]

le left 1 du dernier élément c'est "f " et non";"

a partir du moment ou les caractères précédent et suivants a considérer peuvent être chose qu'un espace TU OUBLIE purement et simplement LE SPLIT!!!!!

parti de la ben, ton code est obsolete et ou non approprié a la demande
tout simplement

 

[cd95]

re
si tu pare de ce code

Option Explicit

Sub ColorerMot_v4()
Dim p, m, dico, i&, s, n&, j&, deb&, Ti, txt, aSuppr As Boolean, xrg As Range, nbMots, ColonneSupp As Boolean
   Ti = Timer
   Application.ScreenUpdating = False
   Application.StatusBar = "Raz des formats en colonne B..."
   Intersect(UsedRange, Range("b:b")).Font.Bold = False
   Intersect(UsedRange, Range("b:b")).Font.ColorIndex = xlColorIndexAutomatic
   Application.StatusBar = "Lecture des mots et phrases..."
   m = Range("a1:b" & Cells(Rows.Count, "a").End(xlUp).Row)
   p = Range("b1:b" & Cells(Rows.Count, "b").End(xlUp).Row)
   Set dico = CreateObject("scripting.dictionary")
   dico.CompareMode = vbTextCompare
   For i = 1 To UBound(m): dico(m(i, 1)) = "": Next
   Application.StatusBar = "Début de l'analyse et formatage des phrases..."
   For i = 1 To UBound(p)
      aSuppr = True
      s = Split(p(i, 1)): deb = 1
      For j = 0 To UBound(s)
         nbMots = nbMots + 1
         txt = s(j)
         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)
         If dico.Exists(txt) Then
            aSuppr = False
            Cells(i, "b").Characters(Start:=deb, Length:=Len(txt)).Font.Bold = True
            Cells(i, "b").Characters(Start:=deb, Length:=Len(txt)).Font.Color = RGB(0, 0, 255)
         End If
         deb = deb + Len(s(j)) + 1
      Next j
      If aSuppr Then p(i, 1) = CVErr(xlErrNA) Else p(i, 1) = Empty
      If i Mod 500 = 0 Then Application.StatusBar = "Phrase " & i & " / " & UBound(p)
   Next i

   'suppression en masse
   Application.StatusBar = "Suppression en cours -> insertion colonne..."
   On Error GoTo Pas2Colonne
   Columns(3).Insert: ColonneSupp = True
   With Columns(3).Resize(UBound(p))
      Application.StatusBar = "Suppression en cours -> remplissage colonne..."
      .Value = p
      Application.StatusBar = "Suppression en cours -> tri..."
      .Offset(, -1).Resize(, 2).Sort key1:=Cells(1, 3), order1:=xlAscending
      Application.StatusBar = "Suppression en cours -> suppression des lignes..."
      .SpecialCells(xlCellTypeConstants, xlErrors).Offset(, -1).EntireRow.Delete xlShiftUp
      Application.StatusBar = "Suppression en cours -> collage valeurs en colonne A..."
      Range("a1").Resize(UBound(m)) = m
   End With
Pas2Colonne:
   On Error GoTo 0
   If ColonneSupp Then Columns(3).Delete
   Application.StatusBar = False
   MsgBox "C'est terminé! Durée= " & Format(Timer - Ti, "0.0\ sec.") & _
      vbLf & UBound(p) & " phrases traitées contenant " & Format(nbMots, "0,000") & " mots.", vbInformation
End Sub

1 des raisons
tu peux pas faire
s = Split(p(i, 1)): deb = 1
qui coupe par les mot (tout court)par les espaces
et espérer avoir toutes concordances valides avec If Right(txt, 1) = "." Or Righ.......etc..etc....

si tu a
toto mange des bananes a la facon;toto
tu rate le toto 2 ";toto" car ton split
[toto] [mange] [des] [bananes] [a] [la] [facon;toto]

le left 1 du dernier élément c'est "f " et non";"

a partir du moment ou les caractères précédent et suivants a considérer peuvent être chose qu'un espace TU OUBLIE purement et simplement LE SPLIT!!!!!

parti de la ben, ton code est obsolete et ou non approprié a la demande
tout simplement

Message reçu, j'ai bien compris donc il ne faut même pas essyer.

 

[patricktoulon]

re
t'é chez free t'a tout compris

 

[cd95]

re
t'é chez free t'a tout compris

J'ai compris pourtant je ne suis pas chez free

 

[patricktoulon]

re
alors t'a la carte kiwi

tu a maintenant 3 codes qui fonctionnent cébolavinon!

 

[cd95]

re
alors t'a la carte kiwi

tu a maintenant 3 codes qui fonctionnent cébolavinon!

Re

Merci, en fait le code que vous m’avez fourni fonctionne à merveille avec du latin mais pas avec les autres langues. Ça m’intrigue !!! alors qu’avec d’autre code ça fonctionne même le fichier dont vous m’avez déconseillé à bidouiller ça fonctionne sauf qu’il ne prend pas en charge les phrases.

 

[cd95]

Re

Merci, en fait le code que vous m’avez fourni fonctionne à merveille avec du latin mais pas avec les autres langues. Ça m’intrigue !!! alors qu’avec d’autre code ça fonctionne même le fichier dont vous m’avez déconseillé à bidouiller ça fonctionne sauf qu’il ne prend pas en charge les phrases.

Surement free a mis un verrouillage pour les autres langues

 

[patricktoulon]

re
dis moi tu bois un peu toi non?

 

[cd95]

re
dis moi tu bois un peu toi non?
Regarde la pièce jointe 1059013

C’est ce que je viens vous dire : il fonctionne correctement et à merveille en latin (français, anglais …) mais pas avec d'autres langues ou les caractères changent complètement (c’est quoi mon but de vous mentir). Le code que vous m’avez fourni je l’utiliserai que pour le Français et il est génial.

 

[patricktoulon]

il faut bien que tu comprenne que la règle c'est un mot ou une lettre ou une phrase précédé et suivi par un caractères séparateur espace ou tout caractères particulier
déjà ça ça devrait te mettre la puce a l'oreille

ca veux dire que si tu essaie un autre langage qui ne respecte pas ces règles de ponctuation ou grammaticale ben tu es chocolat bien, évidemment
c'est impossible de faire un truc qui fonctionne avec toutes les langues sans faire une usine a gaz de part la diversité des règles
LOL
DU coup je vais me boire une binch en espérant quand je reviens tu ai compris

RE LOL

 

[cd95]

il faut bien que tu comprenne que la règle c'est un mot ou une lettre ou une phrase précédé et suivi par un caractères séparateur espace ou tout caractères particulier
déjà ça ça devrait te mettre la puce a l'oreille

ca veux dire que si tu essaie un autre langage qui ne respecte pas ces règles de ponctuation ou grammaticale ben tu es chocolat bien, évidemment
c'est impossible de faire un truc qui fonctionne avec toutes les langues sans faire une usine a gaz de part la diversité des règles
LOL
DU coup je vais me boire une binch en espérant quand je reviens tu ai compris

RE LOL

Ho capito

 

[cd95]

Ho capito

Juste pour info je vous envoie ce petit code pourtant ce n’est pas une usine à gaz et fonctionne avec toutes les autres langues.

Option Explicit
Sub test()

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

'Feuil1.Range("A1:A19") au lieu de Selection et "toto" au lieur de: Application.InputBox("Quelle est la chaîne à mettre en évidence:", "Recherche:", , , , , , 2)

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 au lieu de Selection

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

 

[patricktoulon]

re
la bonne blague
f Mid(" " & xCell.Text & " ", i, Len(xmot) + 2) Like " " & xmot & " " Then

ben si un seul caractères de ponctuation remplace un des espace ben tu es chocolat

essaie de récupérer "toto" avec

"cd95 mange des bananes comme;toto"

ou bien encore

"cd95 eats bananas like;toto"

francais anglais ou du nimportnakoispekitant tu sera dans la penade quand même

tu es un peu dur de la feuille toi hein

on t'a donné 3 avions de chasse et tu nous agite au nez ta trottinette

un gros LOL

 

[mapomme]

tu a testé le fichier compil ?

Oui Oui (même avec du grec ancien - je crois - en fait je n'y connais rien). Très difficile de travailler dans une langue qui emploi d'autres lettres et tout un tas d'accents dont on ne connait pas l'usage.