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
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 !