Lien hypertexte situé sur rectangle appelant feuille masquée

[libellule85]

Bonsoir le forum,

Pour certain de mes classeurs, j'utilise un menu avec des liens hypertextes (situés sur des mots) qui ouvrent des feuilles masquées et qui les referment quand je retourne sur le menu en utilisant la macro ci-dessous.
Ce que je cherche à faire, c'est la même chose mais avec des liens qui se trouvent sur des rectangles à coins arrondis et bien sûr la macro ne fonctionne plus.

Private Const ListeFeuillesCachees As String = "?Janvier?Février?Mars?Avril?Mai?Juin?Juillet?Août?Septembre?Octobre?Novembre?Décembre?"


Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
    'si la feuille ne fait pas partie des feuilles à cacher, quitter la macro
    If InStr(ListeFeuillesCachees, "?" & Sh.Name & "?") = 0 Then Exit Sub
    'masquer la feuille
    Sh.Visible = xlSheetHidden
End Sub


Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Dim nomFeuille As String
    
    'récupérer le nom de la feuille pointée par le lien hypertexte
     nomFeuille = Application.Range(Target.SubAddress).Parent.Name
    
    'si la feuille fait partie des feuilles cachées
    If InStr(ListeFeuillesCachees, "?" & nomFeuille & "?") <> 0 Then
        'afficher la feuille
        On Error Resume Next
         Application.Range(Target.SubAddress).Parent.Visible = xlSheetVisible
        On Error GoTo 0
    End If
    
    'suivre le lien hypertexte
    Application.EnableEvents = False
    Target.Follow
    Application.EnableEvents = True
End Sub

D'avance merci de me dire ce que je dois changer pour que celà fonctionne.

 

[libellule85]

[Résolu] Lien hypertexte situé sur rectangle appelant feuille masquée

Bonsoir le forum,

N'ayant aucune réponse, j'ai mis ce même message sur l'autre excellent forum d'excel qu'est excel-pratique.com et j'ai eu une réponse de Banzai64 (que je remercie une nouvelle fois) que je vous livre ici :

Tout d'abord il faut supprimer les liens hypertextes mis sur les textes dans les rectangles, ensuite mettre dans un module la macro suivante :

Sub AllerOu()
Dim Nom As String
  Nom = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
  On Error Resume Next
  Sheets(Nom).Visible = True
  Application.Goto Sheets(Nom).Range("A1")
End Sub

Et affecter cette macro à chaque rectangle contenant le texte.
Celà fonctionne à merveille.
Donc mon problème est résolu.
Bonne soirée