Microsoft 365 Conserver lien hypertexte avec une fonction RechercheV

Sheets("xxxxxx)").Visible = True

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$6" Then Exit Sub
Dim w As Worksheet, c As Range, sa$, feuille$
For Each w In Worksheets
    If LCase(w.Name) Like "truc*" Then w.Visible = xlSheetHidden 'masque les feuilles
Next w
Set c = Sheets("data").Columns(5).Find(Target(1), , xlValues, xlWhole)
Target(1, 2) = "" 'RAZ
If c Is Nothing Or Target = "" Then Exit Sub
Target(1, 2) = c(1, 2).Value
If c(1, 2).Hyperlinks.Count Then
    sa = c(1, 2).Hyperlinks(1).SubAddress
    Hyperlinks.Add Target(1, 2), "", sa
    feuille = Left(sa, InStr(sa, "!") - 1)
    On Error Resume Next
    If IsError(Sheets(feuille)) Then MsgBox "La feuille " & feuille & " n'existe pas !", 48: Exit Sub
    Sheets(feuille).Visible = xlSheetVisible 'affiche la feuille
End If
End Sub

=LIEN_HYPERTEXTE(RECHERCHEX(C15;Données!H9:H11;Données!I9:I11))

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$B$6" Then Exit Sub
Dim c As Range
Set c = Sheets("data").Columns(5).Find(Target(1), , xlValues, xlWhole)
Target(1, 2) = "" 'RAZ
If c Is Nothing Or Target = "" Then Exit Sub
Target(1, 2) = c(1, 2)
If c(1, 2).Hyperlinks.Count Then Hyperlinks.Add Target(1, 2), "", c(1, 2).Hyperlinks(1).SubAddress
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If LCase(Sh.Name) Like "truc*" Then Sh.Visible = xlSheetHidden 'masque la feuille
End Sub

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal h As Hyperlink)
On Error Resume Next
With Evaluate(h.SubAddress)
    .Parent.Visible = xlSheetVisible 'affiche la feuille
    Application.Goto .Cells
End With
End Sub

Dim sh As Worksheet

For Each sh In ThisWorkbook.Worksheets

With sh

If Not .Name = "test" Then .Visible = False

End With

Next

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Sheets("data")
    If Target.Address = "$A$6" Then
        .Columns("R").Clear
        .[D3].CurrentRegion.Columns(1).Offset(1).Copy .[R1]
        .[R1].CurrentRegion.RemoveDuplicates 1, xlNo
        .[R1].CurrentRegion.Name = "Liste1"
        Target.Validation.Delete
        Target.Validation.Add xlValidateList, Formula1:="=Liste1" 'plage nommée
    ElseIf Target.Address = "$B$6" Then
        Target.Validation.Delete
        Target = ""
        .Columns("T").Clear
        If Application.CountIf(.[D3].CurrentRegion.Columns(1).Offset(1), Target(1, 0)) = 0 Then _
            Target(1, 0).Select: CreateObject("WScript.Shell").SendKeys "%{DOWN}": Exit Sub 'déroule la liste
        .[D3].CurrentRegion.AutoFilter 1, Target(1, 0) 'filtre automatique
        .[D3].CurrentRegion.Columns(2).Offset(1).Copy .[T1]
        .[D3].CurrentRegion.AutoFilter 'ôte le filtre
        .[T1].CurrentRegion.Name = "Liste2" 'plage nommée
        Target.Validation.Add xlValidateList, Formula1:="=Liste2"
    End If
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$6" Then If Target = "" Then [B6:C6] = ""
If Target.Address <> "$B$6" Then Exit Sub
Dim c As Range
Set c = Sheets("data").Columns(5).Find(Target, , xlValues, xlWhole)
Target(1, 2) = "" 'RAZ
If c Is Nothing Or Target = "" Then Exit Sub
Target(1, 2) = c(1, 2)
If c(1, 2).Hyperlinks.Count Then Hyperlinks.Add Target(1, 2), "", c(1, 2).Hyperlinks(1).SubAddress
End Sub

Private Sub Workbook_Open()
Dim s As Object
For Each s In Sheets
    If LCase(s.Name) <> "test" Then s.Visible = xlSheetHidden
Next
Application.Goto [A1], True 'cadrage
Me.Saved = True 'évite l'invite à la fermeture si aucune modification
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
If Not LCase(Sh.Name) = "test" Then Sh.Visible = xlSheetHidden
End Sub

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal h As Hyperlink)
On Error Resume Next
With Evaluate(h.SubAddress)
    .Parent.Visible = xlSheetVisible 'affiche la feuille
    Application.Goto .Cells
End With
End Sub

.ShowError = False

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim tablo, resu(), cible, i&, n&
With Sheets("data")
    If Target.Address = "$A$6" Then
        .Columns("P").Clear
        .[D3].CurrentRegion.Columns(1).Offset(1).Copy .[P1]
        .[P1].CurrentRegion.RemoveDuplicates 1, xlNo
        .[P1].CurrentRegion.Name = "Liste1"
        Target.Validation.Delete
        Target.Validation.Add xlValidateList, Formula1:="=Liste1" 'plage nommée
    ElseIf Target.Address = "$B$6" Then
        Target.Validation.Delete
        .Columns("R:T").Clear
        If Application.CountIf(.[D3].CurrentRegion.Columns(1).Offset(1), Target(1, 0)) = 0 Then _
            Target(1, 0).Select: CreateObject("WScript.Shell").SendKeys "%{DOWN}": Exit Sub 'déroule la liste
        .[D3].CurrentRegion.AutoFilter 1, Target(1, 0) 'filtre automatique
        .[D3].CurrentRegion.Columns(2).Offset(1).Copy .[R1]
        .AutoFilterMode = False 'ôte le filtre
        tablo = .[R1].CurrentRegion.Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
        ReDim resu(1 To UBound(tablo), 1 To 1)
        cible = Target
        For i = 1 To UBound(tablo)
            If InStr(tablo(i, 1), cible) Then n = n + 1: resu(n, 1) = tablo(i, 1)
        Next i
        If n Then
            .[T1].Resize(n) = resu
            .[T1].Resize(n).Name = "Liste2" 'plage nommée
            Target.Validation.Add xlValidateList, Formula1:="=Liste2"
            Target.Validation.ShowError = False
            If Target <> "" Then CreateObject("WScript.Shell").SendKeys "%{DOWN}" 'déroule la liste
        Else
            MsgBox "Pas de correspondance..."
        End If
    End If
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$6" Then If Target = "" Then [B6:C6] = ""
If Target.Address <> "$B$6" Then Exit Sub
Target(1, 2).Select: Target.Select 'lance la macro Worksheet_SelectionChange
Dim c As Range
Set c = Sheets("data").Columns(5).Find(Target, , xlValues, xlWhole)
Target(1, 2) = "" 'RAZ
If c Is Nothing Or Target = "" Then Exit Sub
Target(1, 2) = c(1, 2)
If c(1, 2).Hyperlinks.Count Then Hyperlinks.Add Target(1, 2), "", c(1, 2).Hyperlinks(1).SubAddress
End Sub

Target(1, 2).Select: Target.Select 'lance la macro Worksheet_SelectionChange