XL 2016 rechercher un mot dans une base

[dindin]

Bonjour le forum
j'ai 2 onglet :
- Base
- résultat
le premier contient les colonnes B à F
en A1 le mot à rechercher dans base (colonnes B à F)

cette base contient plus de 6200 lignes.

mon objectif si possible est le suivant :
chercher dans la colonne B (uniquement) le mot se trouvant en A2 de l'onglet base
- le colorier en bleu et le mettre ne gras (que le mot recherché)
- copier les lignes (colonne de A à F ) de répétition de ce mot dans les phrases
- Coller tout ça dans l'onglet Résultat et laisser la base inchangée pour une nouvelle recherche d'un nouveau mot.
chaque résultat d'un nouveau mot recherché sera copié coller à la suite du précédant mot dans l'onglet résultat
comme dans l'exemple du fichier joint
j’espère que mon explication était claire pour vous.

Merci d'avance pour votre aide

 

[dindin]

Grand merci à toi.

 

[laurent950]

Bonsoir patricktoulon, sousou, BOISGONTIER, dindin, Le forum

Procédure, Via module de Classe et Expression Régulière (Regex).

Fichier ci-joint avec code VBA : Option Microsoft VBScript Regular Expressions coché

j'ai 2 onglet :
- Base = OK
- résultat = OK
le premier contient les colonnes B à F = OK
en A1 le mot à rechercher dans base (colonnes B à F) = OK

Si vous avez aimez mon code, donner moi un j'aime ;-))

Laurent950

 

[patricktoulon]

bonsoir laurent 950
je salut le travail de présentation cependant je pense que barre de progression et compagnie c'est un peu to mutch sachant que c'est déja suffisamment long et le regex ici n'a pas sa place sachant que l'expression recherchée est bien clarifiée et ne comporte qu'un seul mot
mais je trouve vraiment ta présentation très bien
et pour une utilisation sur multi pc opte pour le late binding hoistoire de ne pas avoir a activer la ref ou la modifier (en effet elle est différente selon les versions windows

Private reg As Object
Private Matches As Object
'....
'....
'.....
Property Let MotsTrouver(ByRef Fbase As Worksheet, ByRef Fres As Worksheet, ByRef Ttbase() As Variant, ByRef Tmots() As Variant)
'cpt = Fres.Cells(1048576, 1).End(xlUp).Row + 1
    For i = LBound(Ttbase, 1) + 1 To UBound(Ttbase, 1)
        For j = LBound(Ttbase, 2) + 1 To UBound(Ttbase, 2)
            For K = LBound(Tmots) To UBound(Tmots)
                ' instanciation
                    'Set reg = New VBScript_RegExp_55.RegExp
                 Set reg = CreateObject("VBScript.RegExp")
  ' Pattern
                    'reg.Pattern = "(Tableau){1,}"
                    reg.Pattern = "(" & Tmots(K) & "){1,}"
                '  application sur toutes les occurences
                    reg.Global = True
                 '  on ignore la casse
                    reg.IgnoreCase = True
                '  le motif ne porte pas sur plus d'une ligne à la fois
                    reg.MultiLine = False
                    ' Code
                        Set Matches = reg.Execute(Trim(LCase(Ttbase(i, j))))
                            For Each Match In Matches
                            ' Resultat touver à copier (Dans la feuille approprié)
                                CopierResultat Fbase, Fres
                            ' creation lien + Couleur Personalisé
                                CreationLiens Fbase, Fres, Ttbase
                            ' Caractere trouvé identifié dans la chaine de caractére
                                MotTrouverCouleur Fres
                            ' Condition
                                TestLigUnique = True
                        Next Match
            Set Matches = Nothing
            Set Match = Nothing
            Set reg = Nothing
            Next K
        Next j
    ' Incrementation compteur
            'cpt = cpt + i / i
    ' Reinitialise
        TestLigUnique = False
    ' ProgresBar
        PctDone = i / UBound(Ttbase, 1)
        Temp.UpdateProgress PctDone
    Next i
End Property

 

[laurent950]

Bonsoir PartickToulon,
je connais pas se terme : late binding
c'est une liaison tardive ?
Donc pas besoin de coché sur la machine : Option Microsoft VBScript Regular Expressions

Qu'elle est le Type d'Objet
Ps : Avec cette option quand on tape par exemple reg. (Il n'y a pas après le point les méthode et propriété de la classe par Default quand j'utilise Objet), je l'utilise mal certainement ?

Juste :
Private reg As Object
Private Match As Object
Private Matches As Object

Set reg = CreateObject("VBScript.RegExp") '

Cela correspond au late binding ? : https://mhubiche.developpez.com/vba/fiches/comprendre/binding/

Je suis curieux d'apprendre, si il y a un cours ou Tuto ou que vous avez la réponse pour que je puisse l'adapter à un autres de mes codes ou j'utilise votre méthode mais que j'ai pas les bibliothèques par Default après le point.

Regex : Memo

Aide-mémoire des regex / regexp sur ExpReg

Au plaisir de vous lire et d'apprendre à mon tour, se soir il est tard mais demain je vais étudier cela.

un grand merci a vous PatrickToulon

3. Syntaxe des expressions régulières

Laurent

 

[patricktoulon]

re

Ps : Avec cette option quand on tape par exemple reg. (Il n'y a pas après le point les méthode et propriété de la classe par Default quand j'utilise Objet), je l'utilise mal certainement ?

oui en effet en late binding nous n'avons pas l'auto complétion dans et pendant l’édition du code

c'est vrai que pendant l’élaboration du code utiliser le early binding (avec référence cochées) et "as new ...." c'est mieux
mais pour la distribution les remettre en late binding

mais entre nous je le redis utiliser un regex pour chercher un mot bien défini c'est prendre un tank pour aller chercher sa baguette au boulanger
les match te donneront toujours le même mots
même si j'aime bien faire mumuse avec cet object
un regex sert a rechercher ou traiter une EXPRESSION dans une certaine forme représentée par le".pattern"

 

[dindin]

re
bonsoir excuse j'ai eu du boulot

Sub raz()
    Sheets(2).Cells.Clear
End Sub
Sub trans()
    raz
    Dim temoins As Boolean, mot$, p&, x&, oldmot$
    Application.ScreenUpdating = False
    With Sheets("base ")
        mot = ""
        For Each cel In .Range("A2:A51")
            mot = cel.Text
            If mot <> "" Then
                firstrow = Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).Row
                Sheets("Résultat").Cells(firstrow, 1) = mot

                With Sheets("Résultat").Cells(firstrow, 1).End(xlUp)
                    If mot <> oldmot Then .Value = .Value & vbCrLf & "(" & x & " fois)"
                End With
                x = 0
                oldmot = mot
                For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
                    p = InStr(1, .Cells(i, 2).Value, mot)

                    If p > 0 Then
                        .Cells(i, 2).Characters(p, Len(mot)).Font.ColorIndex = 3
                        x = x + 1
                        .Cells(i, 2).Resize(, 6).Copy Destination:=Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1)
                        Debug.Print Cells(i, 2).Address(0, 0) & " position " & p
                        p = 0
                    End If
                Next
            End If
        Next
    End With
End Sub

tu a

1. tes lignes
2. tes mots colorés
3. tes mot en debut de copie en "A"
4. et le compteur

vraiement super
20s pour 50 mots c'est un record pour moi . avec l'ancien code recherche par mot j'ai mis 1 jour pour faire 110 mots (un par un )
j'ai voulu pousser la machine
500 mots et 5000 mots (presque 25 mn).
seule bimole il colorie les mêmes mots s'ils se trouvent dans la même phrase ( c'est un peu logique)
sinon super j'en suis trés satisfait
j'ai rajouté le gras dans l'onglet résultat
et remis la base en noir à la fin du code

 

[dindin]

Bonsoir patricktoulon, sousou, BOISGONTIER, dindin, Le forum

Procédure, Via module de Classe et Expression Régulière (Regex).

Fichier ci-joint avec code VBA : Option Microsoft VBScript Regular Expressions coché

j'ai 2 onglet :
- Base = OK
- résultat = OK
le premier contient les colonnes B à F = OK
en A1 le mot à rechercher dans base (colonnes B à F) = OK

Si vous avez aimez mon code, donner moi un j'aime ;-))

Laurent950

bonjour
tout d'abord merci pour ton travail très pro pour moi qui débute en VBA
néanmoins qq remarques sur son utilité pour l'avancement de mon projet:
- temps d’exécution est trop long pour trouvé un seul mot (ce que je cherche c'est un récap du résultat de chaque)
- ai essayé 4 mots d'un coup : résultat : temps écoulé 856 s et en plus les résultats sont séparés d'une façon à reprendre tout le travail de la recherche derrière.
sinon travail très pro.
voici le travail final comme je le souhaitait et après mise en page de ma part (désolé texte en arabe)

 

[dindin]

re
bonsoir excuse j'ai eu du boulot

Sub raz()
    Sheets(2).Cells.Clear
End Sub
Sub trans()
    raz
    Dim temoins As Boolean, mot$, p&, x&, oldmot$
    Application.ScreenUpdating = False
    With Sheets("base ")
        mot = ""
        For Each cel In .Range("A2:A51")
            mot = cel.Text
            If mot <> "" Then
                firstrow = Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).Row
                Sheets("Résultat").Cells(firstrow, 1) = mot

                With Sheets("Résultat").Cells(firstrow, 1).End(xlUp)
                    If mot <> oldmot Then .Value = .Value & vbCrLf & "(" & x & " fois)"
                End With
                x = 0
                oldmot = mot
                For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
                    p = InStr(1, .Cells(i, 2).Value, mot)

                    If p > 0 Then
                        .Cells(i, 2).Characters(p, Len(mot)).Font.ColorIndex = 3
                        x = x + 1
                        .Cells(i, 2).Resize(, 6).Copy Destination:=Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1)
                        Debug.Print Cells(i, 2).Address(0, 0) & " position " & p
                        p = 0
                    End If
                Next
            End If
        Next
    End With
End Sub

tu a

1. tes lignes
2. tes mots colorés
3. tes mot en debut de copie en "A"
4. et le compteur

Bonsoir tout le monde
Désolé je relance une dernière fois ce post car certaines recherches de mot donnent des résultats qui demandent encore un tri derrière.
Exemple
La recherche du mot ami va me sortir les mots suivants : amie - tamis- rami- tatami- tsunami- amicalement-amitié ...
Je disai certains résultat me donne 500 lignes à trier une 2 ème fois pour en garder qu'une 20.
Peut-on modifier le code pour qu'il détecte que le mot ami uniquement.
Merci pour votre aide.