XL 2016 Procédure événementielle à mettre sur thisworbook

ZZ59264

XLDnaute Occasionnel
Bonjour à tous,

Pourriez vous me donner l'équivalent de ce code qui s'applique sur une feuille spécifique, mais je voudrait l'avoir sur thisworbook pour qu'il soit accessible sur toutes les feuilles du fichier :

VB:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Dim s As String
    Dim cellules As String
    Dim Feuille As String
    Dim lienSplit() As String
    
    Application.ScreenUpdating = False
    lienSplit = Split(Target.SubAddress, "!")
    If UBound(lienSplit) >= 1 Then
        Feuille = Replace(lienSplit(0), "'", "")
        cellules = lienSplit(1)
        With Sheets(Feuille)
        If .Visible = False Then
        .Visible = True
        Application.GoTo .Range(cellules)
        End If
        End With
    Else
     MsgBox ("Lien non valide... " & Target.SubAddress)
    End If
End Sub

Il permet d'accéder a des liens sur des onglets masqués,

Merci d'avance,

Cordialement,
 
Solution
Bonjour ZZ59264, le forum

avec un fichier de test fourni, cela va toujours mieux !

Bien cordialement, @+
VB:
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
    Dim lienSplit() As String
    Dim Feuille As String

    Application.ScreenUpdating = False
    lienSplit = Split(Target.SubAddress, "!")
    If UBound(lienSplit) >= 1 Then
        Feuille = Replace(lienSplit(0), "'", "")
        With ThisWorkbook.Sheets(Feuille)
            If .Visible = False Then
                .Visible = True
                Application.GoTo .Range(lienSplit(1))
            End If
        End With
    Else
        MsgBox ("Lien non valide... " & Target.SubAddress)
    End If
End Sub
Bonjour ZZ59264, le forum

avec un fichier de test fourni, cela va toujours mieux !

Bien cordialement, @+
VB:
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
    Dim lienSplit() As String
    Dim Feuille As String

    Application.ScreenUpdating = False
    lienSplit = Split(Target.SubAddress, "!")
    If UBound(lienSplit) >= 1 Then
        Feuille = Replace(lienSplit(0), "'", "")
        With ThisWorkbook.Sheets(Feuille)
            If .Visible = False Then
                .Visible = True
                Application.GoTo .Range(lienSplit(1))
            End If
        End With
    Else
        MsgBox ("Lien non valide... " & Target.SubAddress)
    End If
End Sub
 

Pièces jointes

  • TEST FORUM - Copie.xlsm
    51.9 KB · Affichages: 2

Discussions similaires

Statistiques des forums

Discussions
311 729
Messages
2 081 970
Membres
101 852
dernier inscrit
dthi16088