Moteur de recherche

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
301moteur-recherche.xlsm (30.87 Ko)

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 !

Rechercher des sujets similaires à "moteur recherche"