Module de recherche élaboré

toine2010 · 16 Décembre 2011

Bonjour,
J'ai profité depuis longtemps des trucs et astuces savamment distillés sur le forum mais là je suis bloqué...
Jusqu'à présent j'avais un fichier excel avec un module de recherche qui permettait de chercher des mots clés dans d'autres onglets et de générer des liens hypertexte pour y accéder et tout fonctionnait très bien...
Je souhaite maintenant pouvoir faire une recherche "multi critère", c'est à dire je tape dans le module chèvre cheval et il me crée un lien hypertext vers toutes les cellules qui contiennent les mots chèvre et cheval, hélas aujourd'hui ça ne fonctionne pas car je n'arrive pas à lui faire également identifier la cellule qui contient cheval chèvre (ordre inversé) et lorsqu'il y a de la ponctuation (,) ça ne fonctionne pas...
En prime je souhaiterais qu'il ne fasse pas de distinction entre chèvre et chevre, c'est à dire qu'il ne prenne pas en compte les accents...
Je vous joins mon fichier de travail, si quelqu'un pouvait m'aider ça serait très sympa
A+

Staple1600 · 17 Décembre 2011

Re : Module de recherche élaboré

Re

Allez j'en remets une couche.
toine2010: tu rendrais tes messages contenant du code VBA plus agréable à lire en utilisant les balises BBCODE adéquates
(ou plus simplement en utilisant cette icone :

)

Tu vois la différence ?
Sans balises
Sub Test()
'Déclarations de Variable
Dim Message As String
Message = Format(Date,"d")
Msgbox Message, 1
End Sub

avec la balise [NOPARSE]

Code:

Macro ici

[/NOPARSE]

Code:

Sub Test()
 'Déclarations de Variable
 Dim Message As String
 Message = Format(Date,"d")
 Msgbox Message, 1
 End Sub

La balise ci-dessous n'a pas d’icône associée (voir ma signature pour son usage)

VB:

Sub Test()
'Déclarations de Variable
Dim Message As String
Message = Format(Date,"d")
Msgbox Message, 1
End Sub

PS: Merci à david84 de partager mon point de vue sur le xls et d'avoir eu la gentillesse de se substituer au demandeur dans cette tâche de conversion.

david84 · 17 Décembre 2011

Re : Module de recherche élaboré

Re
ci-joint nouveau code modifié suite à ta demande :

Code:

Option Explicit
Sub filtrer()
Dim A, c, reponse As String, s As Byte, i&, j&, k&, l&, Nb&, Pl As Range
On Error GoTo Erreur
Sheets("RésultatRecherche").Range("A6:A100").ClearContents
A = Split(Sans_accents(InputBox("Texte ou expression à rechercher"))) 'pour que staple soit moins fatigué !
l = 1
For s = 1 To Sheets.Count
If Sheets(s).Name <> "RésultatRecherche" Then
With Sheets(s)
    Set Pl = Sheets(s).Range("A2").CurrentRegion.Offset(1) _
    .Resize(Sheets(s).Range("A2").CurrentRegion.Rows.Count - 1)
End With

Dim B(), d()
i = 1
ReDim B(1 To Pl.Cells.Count, 1)
For j = 1 To Pl.Columns.Count
    For k = 1 To Pl.Rows.Count
        B(i, 0) = Replace(Sans_accents(Pl(k, j)), ",", "")
        B(i, 1) = Pl(k, j)
        i = i + 1
    Next k
Next j

For i = LBound(B) To UBound(B)
    c = Split(B(i, 0))
    For j = LBound(A) To UBound(A)
        For k = LBound(c) To UBound(c)
            If A(j) = c(k) Then
                Nb = Nb + 1: Exit For
            End If
        Next k
    Next j
    
    If Nb = UBound(A) + 1 Then
        ReDim Preserve d(1 To l)
        d(l) = B(i, 1): l = l + 1
    End If
    Nb = 0
Next i
End If
Next s
Sheets("RésultatRecherche").Range("A6").Resize(UBound(d)) = Application.Transpose(d)

Exit Sub
Erreur:
MsgBox "chaîne de caractère inconnue"
End Sub

Function Sans_accents(Chaine As String) 'http://www.generation-nt.com/reponses/comment-remplacer-caractere-accentue-par-non-accentue-e-mails-entraide-3563901.html
Dim T As String, A As String, B As String
Dim i As Integer, U As String
If Chaine = "" Then Exit Function
T = Chaine
'remplacement des caractères accentués
A = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåèéêëìíîïðñòóôõöùúûüýÿçÇ"
B = "AAAAAAEEEEIIIINOOOOOUUUUYaaaaaaeeeeiiiionooooouuuuyycC"
For i = 1 To Len(T)
U = InStr(1, A, Mid(T, i, 1), 0)
If U Then Mid(T, i, 1) = Mid(B, U, 1)
Next i
Sans_accents = T
End Function

A toi maintenant de terminer le travail.
A+

Staple1600 · 17 Décembre 2011

Re : Module de recherche élaboré

Re

Merci David84

Quand je lis ton code , je suis ému, je le trouve joli.

Et cela change de la grisaille que je vois par la fenêtre

Ceci dit, si JNP venait à passer par là et que tous les deux vous introduisiez une dose de RegExp, ou de Dictionnary, alors, l'extase serait proche

toine2010 · 17 Décembre 2011

Re : Module de recherche élaboré

Merci bcp David84 pour ta rapidité et on efficacité!...
A+

Merci à Staple1600 pour son incruste très productive à cette discussion!!

Staple1600 · 17 Décembre 2011

Re : Module de recherche élaboré

Re

toine2010
Je considère ce conseil (que d'autres que toi qui liront ton fil) est sinon productif au moins profitable
https://www.excel-downloads.com/threads/module-de-recherche-elabore.174992/
Suggérer à David84 (même sur le ton de l'humour) l'emploi de RegExp et l'évocation de JNP
(Je sais qu'il sait à quoi je fais allusion) est juste une invitation à aller plus loin (et au final pour ton bénéfice, non ?)
Pour terminer dans sa dernière version, david84 a bien utilisé la suggestion que je faisais, non ?

VB:

A = Split(Sans_accents(InputBox("Texte ou expression à rechercher"))) 'pour que staple soit moins fatigué !

Néanmoins, si tu trouves que mes messages n'ont rien à faire dans ta discussion, n'hésites pas à demander au modérateur du site de les supprimer.

toine2010 · 17 Décembre 2011

Re : Module de recherche élaboré

Staple1600
Pour moi productif signifiait mettre les mains dans le code!! Comme intégrer les liens hypertexte au code de david84...
A+

Staple1600 · 17 Décembre 2011

Re : Module de recherche élaboré

Re

Ok, je vais mettre la main à la pâte
Nous serons donc trois dans ce cas

car comme le disait david84 il y a peu

A toi maintenant de terminer le travail.

PS: Je viens de relire ton premier message

c'est à dire je tape dans le module chèvre cheval et il me crée un lien hypertext vers toutes les cellules qui contiennent les mots chèvre et cheval, hélas aujourd'hui ça ne fonctionne pas car je n'arrive pas à lui faire également identifier la cellule qui contient cheval chèvre (ordre inversé) et lorsqu'il y a de la ponctuation (,) ça ne fonctionne pas...

un lien hypertexte pointe vers une cellule unique si je rappelle bien (quand on choisit Emplacement dans ce document), dans ce cas je ne vois pas comment réaliser cette partie de ta demande:

il me crée un lien hypertext vers toutes les cellules qui contiennent les mots chèvre et cheval

Car une cellule ne peut contenir qu'un seul lien hypertext non ? donc amener vers un seul emplacement (pas plusieurs)

david84 · 17 Décembre 2011

Re : Module de recherche élaboré

Re
@toine2010 : on se détend

! On es là pour t'aider mais également pour échanger entre nous dans une atmosphère sympa.
Avec staple, il faut savoir lire entre les lignes et être à l'écoute des conseils distillés par un MegaBarbatruc.
Concernant le RegExp, une fois de plus il a raison :

Le delimiter de split étant l'espace dans ton code, imagine qu'au lieu de rentrer
"chat chevre", tu t'endormes un peu sur ton clavier et que tu rentres
" chat (5 espaces) chevre ".
En l'état ta chaîne de caractères ne peut être traitée.
Maintenant, teste ce cas de figure avec ce code :

Code:

Option Explicit
Sub filtrer()
Dim A, c, reponse As String, s As Byte, i&, j&, k&, l&, Nb&, Pl As Range
On Error GoTo Erreur
Sheets("RésultatRecherche").Range("A6:A100").ClearContents
A = Split(Extractions(Sans_accents(InputBox("Texte ou expression à rechercher")), " +", " ")) 'suite aux conseils avisés de staple
l = 1
For s = 1 To Sheets.Count
If Sheets(s).Name <> "RésultatRecherche" Then
With Sheets(s)
    Set Pl = Sheets(s).Range("A2").CurrentRegion.Offset(1) _
    .Resize(Sheets(s).Range("A2").CurrentRegion.Rows.Count - 1)
End With

Dim B(), d()
i = 1
ReDim B(1 To Pl.Cells.Count, 1)
For j = 1 To Pl.Columns.Count
    For k = 1 To Pl.Rows.Count
        B(i, 0) = Replace(Sans_accents(Pl(k, j)), ",", "")
        B(i, 1) = Pl(k, j)
        i = i + 1
    Next k
Next j

For i = LBound(B) To UBound(B)
    c = Split(B(i, 0))
    For j = LBound(A) To UBound(A)
        For k = LBound(c) To UBound(c)
            If A(j) = c(k) Then
                Nb = Nb + 1: Exit For
            End If
        Next k
    Next j
    
    If Nb = UBound(A) + 1 Then
        ReDim Preserve d(1 To l)
        d(l) = B(i, 1): l = l + 1
    End If
    Nb = 0
Next i
End If
Next s
Sheets("RésultatRecherche").Range("A6").Resize(UBound(d)) = Application.Transpose(d)

Exit Sub
Erreur:
MsgBox "chaîne de caractère inconnue"
End Sub

Function Sans_accents(Chaine As String) 'http://www.generation-nt.com/reponses/comment-remplacer-caractere-accentue-par-non-accentue-e-mails-entraide-3563901.html
Dim T As String, A As String, B As String
Dim i As Integer, U As String
If Chaine = "" Then Exit Function
T = Chaine
'remplacement des caractères accentués
A = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåèéêëìíîïðñòóôõöùúûüýÿçÇ"
B = "AAAAAAEEEEIIIINOOOOOUUUUYaaaaaaeeeeiiiionooooouuuuyycC"
For i = 1 To Len(T)
U = InStr(1, A, Mid(T, i, 1), 0)
If U Then Mid(T, i, 1) = Mid(B, U, 1)
Next i
Sans_accents = T
End Function
Function Extractions(Texte As String, MonPattern As String, Optional Remplacement As String, Optional Inverse As Boolean) As String 'par JNP
Dim Match, Matches
If Inverse = False Then
    With CreateObject("vbscript.regexp")
        .Global = True: .Pattern = MonPattern
        Extractions = Trim(.Replace(Texte, Remplacement))
    End With
Else
    With CreateObject("vbscript.regexp")
        .Global = True: .Pattern = Replace(MonPattern, " ?", "")
        Set Matches = .Execute(Texte)
        For Each Match In Matches
            Extractions = Extractions & " " & Match
        Next
    End With
    Extractions = Trim(Extractions)
End If
End Function

Vois-tu la différence ? Là ta chaîne de caractère est tout de même traitée.
C'est juste pour te donner un aperçu du RegExp et t'expliquer pourquoi staple évoquait le RegExp et JNP (cette fonction est de lui).
Et l'on peut sûrement utiliser le RegExp à d'autres occasions dans cette procédure (mais là, c'est juste pour te faire comprendre son utilité).

Par contre staple, concernant le dictionary, je ne vois pas trop (une petite idée tout de même mais trop ténue

)... un indice supplémentaire STP

?
A+

toine2010 · 17 Décembre 2011

Re : Module de recherche élaboré

David84, ne polémiquons pas! J'ai bien vu que tu échangeais avec staple1600, çe ne me gênait pas du tout! C'est juste les messages donneurs de leçons sur .xls, copie/colle de code qui étaient un peu relous...

Staple1600 : pour le lien hypertexte, c'est comme dans le tout premier fichier que j'ai posté, le lien hypertexte pointe vers la cellule où se trouve l'élément recherché. Ce que je n'arrivais pas à faire c'était une recherche exhaustive (accents, plusieurs mots...) là où David84 m'a dépanné. Seulement la structure de sa macro est (pour moi!) assez complexe et j'ai du mal à y réintégrer mon lien hypertexte...

A+

Staple1600 · 17 Décembre 2011

Re : Module de recherche élaboré

Re

Merci David84 (je te dois une extase (non charnelle bien entendu)

)
Par contre, comment tu t'en sors avec cette histoire de liens hypertexte?
J'ai du mal à voir comment biaiser la chose.

toine2010: concernant le lien hypertexte
Tu veux donc un lien uniquement vers la colonne Titre de la feuille REGQSA ou SPEQSA
Si c'est cela comment un lien hypertexte peut te mener à deux endroits différents ?

PS1: JNP: di tu passes par là, rejoins la troupe, et amène tes patterns de folie avec toi.

PS: On s'est mal compris toine2010, tu ne penses que les messages de david84 sont plus agréables à lire parce qu'il a mis son code VBA entre balises ?
Je t'invitais juste à faire de même (c'est possible en mode édition) pour rendre ta discussion plus agréable à lire.
Libre à toi de la faire ou pas.

david84 · 17 Décembre 2011

Re : Module de recherche élaboré

Re
@Toine2010:

David84, ne polémiquons pas!

Loin de moi cette idée

.
Pour en revenir à ton lien hypertexte, je regarde ce que je peux te proposer.
@staple :

Merci David84 (je te dois une extase (non charnelle bien entendu) )

Ecoute, c'est toujours ça de pris

!
Concernant le lien hypertexte, je pense qu'il faut trouver le moyen d'enregistrer dans le tableau VBA l'adresse et la feuille de la cellule concernée, peut-être en rajoutant une colonne à l'array B... mais bon ce n'est qu'une idée !
Je vais y regarder de plus près.
A+

david84 · 17 Décembre 2011

Re : Module de recherche élaboré

Re
à tester et dis-nous :

Code:

Option Explicit
Sub filtrer()
Dim A, c, reponse As String, s As Byte, i&, j&, k&, l&, Nb&, Pl As Range
On Error GoTo Erreur
Sheets("RésultatRecherche").Range("A6:A100").ClearContents
A = Split(Extractions(Sans_accents(InputBox("Texte ou expression à rechercher")), " +", " ")) 'suite aux conseils avisés de staple
l = 1
For s = 1 To Sheets.Count
If Sheets(s).Name <> "RésultatRecherche" Then
With Sheets(s)
    Set Pl = Sheets(s).Range("A2").CurrentRegion.Offset(1) _
    .Resize(Sheets(s).Range("A2").CurrentRegion.Rows.Count - 1)
End With

Dim b(), d()
i = 1
ReDim b(1 To Pl.Cells.Count, 2)
For j = 1 To Pl.Columns.Count
    For k = 1 To Pl.Rows.Count
        b(i, 0) = Replace(Sans_accents(Pl(k, j)), ",", "")
        b(i, 1) = Pl(k, j)
        b(i, 2) = Sheets(s).Name & "#" & Pl(k, j).Address
        i = i + 1
    Next k
Next j

For i = LBound(b) To UBound(b)
    c = Split(b(i, 0))
    For j = LBound(A) To UBound(A)
        For k = LBound(c) To UBound(c)
            If A(j) = c(k) Then
                Nb = Nb + 1: Exit For
            End If
        Next k
    Next j
    
    If Nb = UBound(A) + 1 Then
        ReDim Preserve d(1 To l)
        d(l) = b(i, 1) & "#" & b(i, 2)
        'd(l, 1) = b(i, 2)
         l = l + 1
    End If
    Nb = 0
Next i
End If
Next s

Dim e()
For i = LBound(d) To UBound(d)
    ReDim Preserve e(1 To UBound(d))
    e(i) = Split(d(i), "#")
    Sheets("RésultatRecherche").Cells(i + 5, 1) = e(i)(0)
    Sheets("RésultatRecherche").Cells(i + 5, 1).Hyperlinks.Add Anchor:=Sheets("RésultatRecherche").Cells(i + 5, 1), Address:="", SubAddress:= _
    Sheets(e(i)(1)).Name & "!" & e(i)(2), TextToDisplay:=e(i)(0)
Next i
Exit Sub
Erreur:
MsgBox "chaîne de caractère inconnue"
End Sub

Function Sans_accents(Chaine As String) 'http://www.generation-nt.com/reponses/comment-remplacer-caractere-accentue-par-non-accentue-e-mails-entraide-3563901.html
Dim T As String, A As String, b As String
Dim i As Integer, U As String
If Chaine = "" Then Exit Function
T = Chaine
'remplacement des caractères accentués
A = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåèéêëìíîïðñòóôõöùúûüýÿçÇ"
b = "AAAAAAEEEEIIIINOOOOOUUUUYaaaaaaeeeeiiiionooooouuuuyycC"
For i = 1 To Len(T)
U = InStr(1, A, Mid(T, i, 1), 0)
If U Then Mid(T, i, 1) = Mid(b, U, 1)
Next i
Sans_accents = T
End Function
Function Extractions(Texte As String, MonPattern As String, Optional Remplacement As String, Optional Inverse As Boolean) As String 'par JNP
Dim Match, Matches
If Inverse = False Then
    With CreateObject("vbscript.regexp")
        .Global = True: .Pattern = MonPattern
        Extractions = Trim(.Replace(Texte, Remplacement))
    End With
Else
    With CreateObject("vbscript.regexp")
        .Global = True: .Pattern = Replace(MonPattern, " ?", "")
        Set Matches = .Execute(Texte)
        For Each Match In Matches
            Extractions = Extractions & " " & Match
        Next
    End With
    Extractions = Trim(Extractions)
End If
End Function

A+

toine2010 · 17 Décembre 2011

Re : Module de recherche élaboré

Tout simplement BRAVO David 84! C'est tout à fait ce dont j'avais besoin...
A+

david84 · 17 Décembre 2011

Re : Module de recherche élaboré

Re

Tout simplement BRAVO David 84! C'est tout à fait ce dont j'avais besoin...

Merci toine2010, mais n'oublie pas staple tout de même, si l'on n'avait pas échangé, je n'aurai pas poussé le bouchon aussi loin

.
A+

toine2010 · 17 Décembre 2011

Re : Module de recherche élaboré

Re
Désolé de revenir à la charge, mais j'ai un dernier problème! La variable Pl.Columns.Count est "bloquée" à 6 alors qu'il devrait couvrir toutes les colonnes où il y a du texte sur la ligne 8. Je ne sais pas pourquoi il y a ce pb...
Merci pour un dernier coup de pouce...
A+

Module de recherche élaboré

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

Discussions similaires

Partager cette page

Statistiques des forums