XL 2016 Recherche mot dans texte

[kaki31]

Bonjour,
j'ai besoin de faire une recherche a partir de feuil2 B2 pour afficher les cellules de Feuil1 A contenant de mot et colorer ce mot,et afficher le nombre de mot trouvé.
Merci.
🙂

 

[Jacky67]

Bonjour,
j'ai besoin de faire une recherche a partir de feuil2 B2 pour afficher les cellules de Feuil1 A contenant de mot et colorer ce mot,et afficher le nombre de mot trouvé.
Merci.
🙂

Bonjour,
Une proposition par vba en PJ

 

[mapomme]

Bonjour à @kaki31🙂, @Jacky67😉,

Un autre code vba qui :

• ne distingue pas les majuscules des minuscules
• qui colore toutes les occurrences du mot recherché si ce dernier est présent plusieurs fois dans la ligne.
• qui colore seulement les mots entiers égaux au mot recherché (ni Loremlorem ni Loremtum ni quidlorem ne seront retenus). Le séparateur de mots est l'espace. Ce qui en toute rigueur est faux en français. En français un séparateur de mots peut être tout signe de ponctuation. Exemple: Lorem, toto. Si vous désirez tenir compte des séparateurs autres que les espaces, il faudra modifier la procédure. Me le demander...
• le code est un peu commenté

Sub RechercherMot()
Dim mot$, derlig&, t, i&, j&, nlig&, s, nc&, lignes&, mots&
   With Worksheets("Feuil2")
      ' effacement précédents résultats - titre de la colonne A
      .Columns(1).Clear: .[a1] = "Résultat": .[a1].Font.Bold = True
      ' lecture du mot à chercher - mise à zéro des nombres de lignes et mots trouvés
      mot = LCase(.[b2]): .[b5] = 0: .[b8] = 0
      Application.ScreenUpdating = False
   End With
 
   With Worksheets("Feuil1")
      If .FilterMode Then .ShowAllData                   ' si filtre alors tout afficher
      derlig = .Cells(Rows.Count, "b").End(xlUp).Row     ' dernière ligne des données de la source
      If derlig = 1 Then Exit Sub                        ' si aucune données alors on quitte
      t = .Range("b2:b" & derlig)                        ' lecture des données sources dans le tableau t
   End With
 
   With Worksheets("Feuil2")
      nlig = 1                   ' nlig est la dernière ligne écrite dans le résultat (=1 car il y a un titre)
      For i = 1 To UBound(t)     ' boucle sur les lignes sources
         ' on teste si le MOT cherché est dans la ligne source i
         If InStr(1, " " & t(i, 1) & " ", " " & mot & " ", vbTextCompare) > 0 Then
            ' si oui alors on inscrit la ligne source dans le résultat. On incrémente le nombre de lignes trouvées
            ' on incrémente la ligne d'écriture et on inscrit la ligne sur la feuille résultat
            lignes = lignes + 1: nlig = nlig + 1: .Cells(nlig, "a") = t(i, 1)
            ' on transfère les mots de la ligne dans le tableau s (de base 0)
            ' nc est le compteur de caractères de la ligne. On commence au caractère n° 1
            s = Split(t(i, 1)): nc = 1
            For j = 0 To UBound(s)     'boucle sur les mots de la ligne
               ' si le mots j est égal au mot cherché, alors on le colore en rouge
               If LCase(s(j)) = mot Then mots = mots + 1: .Cells(nlig, "a").Characters(nc, Len(mot)).Font.Color = vbRed
               nc = nc + Len(s(j)) + 1    ' le prochain mot commencera au caractère nc + la longueur du mot j + 1 (le séparateur espace)
            Next j
         End If
      Next i
      .[b5] = lignes: .[b8] = mots     ' affichage des statistiques
   End With
End Sub

 

[kaki31]

Bonjour,
Une proposition par vba en PJ

Bonjour,
Merci pour votre contribution.

 

[kaki31]

Bonjour à @kaki31🙂, @Jacky67😉,

Un autre code vba qui :

• ne distingue pas les majuscules des minuscules
• qui colore toutes les occurrences du mot recherché si ce dernier est présent plusieurs fois dans la ligne.
• qui colore seulement les mots entiers égaux au mot recherché (ni Loremlorem ni Loremtum ni quidlorem ne seront retenus). Le séparateur de mots est l'espace. Ce qui en toute rigueur est faux en français. En français un séparateur de mots peut être un signe de ponctuation. Exemple: Lorem, toto. Si vous désirez tenir compte de ses séparateurs autres que les espaces, il faudra modifier la procédure. Me le demander...
• le code est un peu commenté

Sub RechercherMot()
Dim mot$, derlig&, t, i&, j&, nlig&, s, nc&, lignes&, mots&
   With Worksheets("Feuil2")
      ' effacement précédents résultats - titre de la colonne A
      .Columns(1).Clear: .[a1] = "Résultat": .[a1].Font.Bold = True
      ' lecture du mot à chercher - mise à zéro des nombres de lignes et mots trouvés
      mot = LCase(.[b2]): .[b5] = 0: .[b8] = 0
      Application.ScreenUpdating = False
   End With
 
   With Worksheets("Feuil1")
      If .FilterMode Then .ShowAllData                   ' si filtre alors tout afficher
      derlig = .Cells(Rows.Count, "b").End(xlUp).Row     ' dernière ligne des données de la source
      If derlig = 1 Then Exit Sub                        ' si aucune données alors on quitte
      t = .Range("b2:b" & derlig)                        ' lecture des données sources dans le tableau t
   End With
 
   With Worksheets("Feuil2")
      nlig = 1                   ' nlig est la dernière ligne écrite dans le résultat (=1 car il y a un titre)
      For i = 1 To UBound(t)     ' boucle sur les lignes sources
         ' on teste le MOT cherché est dans la ligne source i
         If InStr(1, " " & t(i, 1) & " ", " " & mot & " ", vbTextCompare) > 0 Then
            ' si oui alors on inscrit la ligne source dans le résultat. On incrémente le nombre de lignes trouvées
            ' on incrémente la ligne d'écriture et on inscrit la ligne sur la feuille résultat
            lignes = lignes + 1: nlig = nlig + 1: .Cells(nlig, "a") = t(i, 1)
            ' on transfère les mots de la ligne dans le tableau s (de base 0)
            ' nc est le compteur de caractères de la ligne. On commence au caractère n° 1
            s = Split(t(i, 1)): nc = 1
            For j = 0 To UBound(s)     'boucle sur les mots de la ligne
               ' si le mots j est égal au mot cherché, alors on le colore en rouge
               If LCase(s(j)) = mot Then mots = mots + 1: .Cells(nlig, "a").Characters(nc, Len(mot)).Font.Color = vbRed
               nc = nc + Len(s(j)) + 1    ' le prochain mot commencera au caractère nc + la longueur du mot j + 1 (le séparateur espace)
            Next j
         End If
      Next i
      .[b5] = lignes: .[b8] = mots     ' affichage des statistiques
   End With
End Sub

Bonjour, et merci pour votre contribution,la méthode prend en charge tous les cas, si c'est possible d'afficher en face chaque résultat le nombre de fois que le mot apparaît, et ajouter une liste de choix pour choisir l'affichage :mot entier ou non (lorem ou loremlorem)

Merci.
🙂

 

[mapomme]

Re 🙂,

si c'est possible d'afficher en face chaque résultat le nombre de fois que le mot apparaît, et ajouter une liste de choix pour choisir l'affichage :mot entier ou non (lorem ou loremlorem)

C'est possible mais pour ma pomme pas avant cette nuit...

 

[crocrocro]

Bonjour à tous
Comme l'écrit @mapomme,

Le séparateur de mots est l'espace. Ce qui en toute rigueur est faux en français. En français un séparateur de mots peut être tout signe de ponctuation.

à quoi on pourrait peut-être aussi ajouter parenthèses, saut de ligne ...

• le code est un peu commenté

@mapomme, trop modeste 😂
@kaki31, il est vrai que certaines réponses amènent parfois d'autres demandes, mais c'est mieux quand la demande est complète, cela permet à ceux qui répondent, d'adapter au mieux leurs réponses et donc de ne pas devoir parfois "casser leur code", ce qui peut être désagréable.
Je recycle ma boutade "Quand on s'est inscrit à un duathlon alors que sur la ligne de départ, c'est un triathlon, c'est pas évident d'emprunter un maillot de bain"

 

[mapomme]

Re @kaki31, re @crocrocro, 😉

Bon je me contredis. Je l'ai fait tout de suite, un peu à la va-vite, en incluant ce que vous avez demandé, à savoir :

• ajouter une liste de séparateurs (y compris le saut de ligne comme suggéré judicieusement par @crocrocro )
• choisir de rechercher le mot ou bien le groupe de caractères (cellule D5)
• afficher en face de chaque ligne retenue le nombre d'occurrence au sein de la ligne

C'est un peu brouillon mais ça doit marcher.

 

[job75]

Bonjour à tous,

La définition d'un mot est compliquée, elle dépend en effet des séparateurs utilisés.

Dans ce genre de problème on recherchera plutôt les occurrences et c'est bien simple :

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$2" Then Exit Sub
Dim cible$, L%, c As Range, x$, i%, n&
cible = CStr([B2])
If cible = "" Then cible = Chr(1)
L = Len(cible)
Columns(1).Clear 'RAZ
With Feuil1.Range("B1", Feuil1.Range("B1048576").End(xlUp))
    .AutoFilter
    .AutoFilter 1, "*" & cible & "*"
    .SpecialCells(xlCellTypeVisible).Copy [A1]
    .AutoFilter
End With
For Each c In [A1].CurrentRegion.Columns(1).Cells
    x = c
    For i = 1 To Len(x) - L + 1
        If Mid(x, i, L) = cible Then c.Characters(i, L).Font.Color = vbRed: n = n + 1
Next i, c
[B5] = n
End Sub

Edit : ajouté If cible = "" Then cible = Chr(1)

A+

 

[job75]

Bonjour le forum,

Pour rechercher les mots voici une solution assez simple.

L'occurrence n'est pas un mot si le caractère qui la suit ou la précède est une lettre ou un chiffre :

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cible$, L%, choix$, nlig&, a, i&, x$, j%, coloreMot As Boolean, test As Boolean
If Intersect(Target, [D2:E2]) Is Nothing Then Exit Sub
cible = CStr([D2])
If cible = "" Then cible = Chr(1)
L = Len(cible)
choix = [E2] 'liste de validation
Application.ScreenUpdating = False
Columns(1).Clear 'RAZ
With Feuil1.Range("B1", Feuil1.Range("B1048576").End(xlUp))
    .AutoFilter
    .AutoFilter 1, "*" & cible & "*"
    .SpecialCells(xlCellTypeVisible).Copy [A1]
    .AutoFilter
End With
nlig = [A1].CurrentRegion.Rows.Count
ReDim a(1 To nlig, 1 To 2)
a(1, 1) = "Nbre occurences": a(1, 2) = "Nbre mots"
For i = 2 To nlig
    x = Cells(i, 1)
    For j = 1 To Len(x) - L + 1
        If Mid(x, j, L) = cible Then
            a(i, 1) = a(i, 1) + 1: a(i, 2) = a(i, 2) + 1
            coloreMot = choix = "Mots"
            test = Mid(x, j + L, 1) Like "[A-Z]" Or Mid(x, j + L, 1) Like "[0-9]"
            If j = 1 And test Then a(i, 2) = a(i, 2) - 1:  coloreMot = False
            If j > 1 Then If Mid(x, j - 1, 1) Like "[A-Z]" Or Mid(x, j - 1, 1) Like "[0-9]" Or test Then a(i, 2) = a(i, 2) - 1: coloreMot = False
            If coloreMot Or choix = "Occurrences" Then Cells(i, 1).Characters(j, L).Font.Color = vbRed
        End If
Next j, i
[B1].Resize(nlig, 2) = a
[B1].Offset(nlig).Resize(Rows.Count - nlig, 2).ClearContents 'RAZ en dessous
End Sub

Les occurrences ou les mots sont colorés suivant la liste de validation en E2.

Bien entendu cette solution est simplificatrice, par exemple lorem sera repéré comme mot avec #lorem#.

A+

 

[job75]

La macro précédente est rapide, pour tester j'ai copié les lignes 2 à 14 du tableau source sur 13 000 lignes :
- occurrences => 0,93 seconde
- mots => 0,77 seconde.

 

[jurassic pork]

La macro précédente est rapide, pour tester j'ai copié les lignes 2 à 14 du tableau source sur 13 000 lignes :
- occurrences => 0,93 seconde
- mots => 0,77 seconde.

Hello,
et voici une solution sans utiliser d'autofiltre , en utilisant les expressions régulières :

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cible$, L%, c As Range, x$, i, n&, src, row, nbFois, choix
Dim regex As Object, matches As Object, Match As Object
Dim DestArr() As String, DestPla() As String, z As Integer
If Intersect(Target, [D2:E2]) Is Nothing Then Exit Sub
cible = CStr([D2])
If cible = "" Then cible = Chr(1)
L = Len(cible)
choix = [E2] 'liste de validation
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True: regex.IgnoreCase = True
If choix = "Mots" Then
    regex.Pattern = "\b" & cible & "\b"
Else
    regex.Pattern = cible
End If
src = Feuil1.Range("B1", Feuil1.Range("B1048576").End(xlUp)).Cells.Value
ReDim DestArr(UBound(src) - LBound(src) + 1)
ReDim DestPla(UBound(src) - LBound(src) + 1)
ReDim nbFois(UBound(src) - LBound(src) + 1)
z = 0
For Each row In src
   Set matches = regex.Execute(row)
   If matches.Count Then
      DestArr(z) = row
      For Each Match In matches
          DestPla(z) = DestPla(z) & CStr(Match.FirstIndex + 1) & ","
          nbFois(z) = nbFois(z) + 1
      Next
      DestPla(z) = Left(DestPla(z), Len(DestPla(z)) - 1)
      z = z + 1
   End If
Next
ReDim Preserve DestArr(z - 1)
ReDim Preserve DestPla(z - 1)
ReDim Preserve nbFois(z - 1)
Range("A1:B" & CStr(z + 1)).Clear 'RAZ
[A1] = "TEXTE"
[B1] = "Nb de fois"
Range("A2:A" & CStr(z + 1)) = WorksheetFunction.Transpose(DestArr)
Range("B2:B" & CStr(z + 1)) = WorksheetFunction.Transpose(nbFois)
x = LBound(DestPla)
L = Len(cible)
n = 0
For Each c In Range("A2:A" & CStr(z + 1)).Cells
    For Each i In Split(DestPla(x), ",")
      c.Characters(CInt(i), L).Font.Color = vbRed
      n = n + 1
    Next i
    x = x + 1
Next c
Range("C1") = n
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Les \b dans le motif permettent de "délimiter" les mots.
En performance le code est équivalement à celui de job75 pour 13000 lignes, sachant que le plus gros du temps est pris par la coloration du texte. Donc moins il y aura de mots trouvés, plus vite ira la macro.

Ami calmant, J.P