Moteur de recherche

Pour écrire et partager des tutoriels et des astuces (Excel, Calc et Google Sheets uniquement)
Avatar du membre
Game Over
Membre dévoué
Membre dévoué
Messages : 780
Appréciations reçues : 2
Inscrit le : 9 mars 2013
Version d'Excel : 2016 EN
Contact :

Message par Game Over » 28 avril 2013, 11:43

Bonjour,

le but de ce programme est de générer automatiquement, lorsqu'une requête est saisie, une liste d'hyperliens qui enverront l'utilisateur directement vers les résultats de recherche.

Ici, la recherche se fait pour retrouver un onglet dans le classeur mais en adaptant un peu le code, on pourrait étendre sa fonction à d'autres usages.

La recherche se fait en saisissant le nom ou une partie du nom de l'onglet dans la cellule D4.
A noter qu'il n'est pas nécessaire de respecter la casse pour faire la recherche.
Si l'on veut limiter la recherche uniquement aux premières lettres du nom et pas à n'importe quelle partie du nom, il faudra changer cette partie du code
        '************************************************************************************************************
            If bb >= 1 Then '*** >= extraction par une partie du mot - si > strict alors extraction par début du mot
        '************************************************************************************************************
par
        '************************************************************************************************************
            If bb > 1 Then '*** >= extraction par une partie du mot - si > strict alors extraction par début du mot
        '************************************************************************************************************
Une fois la saisie validée en tapant Entrée, apparait la liste des réponses dans la colonne F si celles-ci existent.

Les champs de recherche et de résultats sont ensuite automatiquement réinitialisés.

Le code complet (à mettre dans le module de la feuille de recherche) :

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

Dim Nb As Integer, Tablo As Variant, myName As String, bb As Integer, c As Integer, ee As Integer, ff As String, dd As String
  
Nb = Sheets.Count
ReDim Tablo(Nb)

myName = Range("D4")

c = 4
ee = 0
If Not Intersect(Target, Range("D4")) Is Nothing And IsEmpty(Target) Then 'efface les résultats lorsqu'on efface D4 avec le bouton Suppr
    Efface
End If

If Not Intersect(Target, Range("D4")) Is Nothing And Not IsEmpty(Target) Then

    Efface

    For a = 2 To Nb
    Tablo(a - 1) = Sheets(a).Name
    ff = Tablo(a - 1) 'nom de l'onglet sans espace ni tiret
    dd = "'" & ff & "'" 'nom de l'onglet contenant un espace ou un tiret
    
    On Error Resume Next 'erreur si la fonction Search est fausse
               
        bb = Application.WorksheetFunction.Search(myName, ff, 1) 'extrait les caractères tapés du nom de l'onglet ***
        If Err = 0 Then 'si l'extraction réussit alors
        '************************************************************************************************************
            If bb >= 1 Then '*** >= extraction par une partie du mot - si > strict alors extraction par début du mot
        '************************************************************************************************************
                ee = Application.WorksheetFunction.Search(" ", ff, 1) 'recherche un espace dans le nom de l'onglet
                gg = Application.WorksheetFunction.Search("-", ff, 1) 'recherche un tiret dans le nom de l'onglet
                    If ee <> 0 Or gg <> 0 Then 'si espace ou tiret dans le nom alors
                        ActiveSheet.Hyperlinks.Add Anchor:=Cells(c, 6), Address:="", _
                        SubAddress:=dd & "!A1", TextToDisplay:=ff 'cette formule
                    Else 'sinon
                        ActiveSheet.Hyperlinks.Add Anchor:=Cells(c, 6), Address:="", _
                         SubAddress:=ff & "!A1", TextToDisplay:=ff 'celle-ci
                    End If
                c = c + 1
            End If
        End If
    ee = 0
    Next a
    
    On Error GoTo 0

    If c = 4 Then
        Efface
        MsgBox "Aucune valeur ne correspond à votre recherche.": Range("D4").ClearContents: Exit Sub 'si pas de résultat
    End If
    [F3].CurrentRegion.Sort key1:=[F3], order1:=xlAscending, Header:=xlYes 'tri des résultats par ordre alphabétique
End If

Set Tablo = Nothing
Application.ScreenUpdating = True

End Sub

Sub Efface()
        If Not IsEmpty(Range("F5")) Then 'réinitialise le champ des résultats
            Range(Range("F4"), Range("F" & Rows.Count).End(xlUp)).ClearContents
        Else
            Range("F4").ClearContents
        End If
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Efface 'réinitialise le champ des résultats
    Range("D4").ClearContents
End Sub

Moteur recherche.xlsm
(30.87 Kio) Téléchargé 268 fois
a
apt
Membre dévoué
Membre dévoué
Messages : 578
Inscrit le : 9 mars 2006
Version d'Excel : 2007 FR

Message par apt » 22 mai 2013, 12:58

Bonjour Gave Over,

Merci pour cette application.

Apres quelques tests, la recherche se passe bien. Apres clique sur un lien et ouverture de la page sélectionnée, et en voulant revenir sur les résultats de la recherche dans la feuille "Ref", ces derniers sont effacés à l'activation de cette dernière.

Voila !
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message
  • moteur de recherche
    par tof63 » 20 janvier 2017, 16:42 » dans Excel - VBA
    2 Réponses
    356 Vues
    Dernier message par tof63
    23 janvier 2017, 08:16
  • Moteur de recherche
    par zairios » 17 octobre 2018, 19:51 » dans Excel - VBA
    7 Réponses
    262 Vues
    Dernier message par zairios
    18 octobre 2018, 20:28
  • Moteur de recherche
    par chastaing » 27 mai 2014, 10:56 » dans Excel - VBA
    1 Réponses
    713 Vues
    Dernier message par gloub
    27 mai 2014, 12:31
  • moteur de recherche
    par julien35000 » 4 avril 2015, 22:00 » dans Excel - VBA
    5 Réponses
    558 Vues
    Dernier message par julien35000
    5 avril 2015, 11:31
  • moteur de recherche
    par nasri sami » 28 mars 2015, 00:38 » dans Excel - VBA
    4 Réponses
    537 Vues
    Dernier message par nasri sami
    28 mars 2015, 12:29
  • Moteur de recherche
    par NicolasL » 5 février 2018, 11:10 » dans Excel - VBA
    3 Réponses
    288 Vues
    Dernier message par h2so4
    6 février 2018, 13:52