Bonjour à tous,

Petit nouveau dans ce forum, je vous demande d'avance de m'excuser si mes procédures d'utilisation du forum ne sont pas encore rodées.

J'ai un classeur Excel (.xlsm) qui présente sur une page des listes déroulantes contenant des liens hypertexte.

J'ai récupéré le code VBA ci-dessous qui fonctionne très bien sur la première liste (Merci à Didier Fourgeot).

Dans les autres listes, les liens sont visibles mais ne fonctionnent pas

'ABATS
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Cel As Range
Dim ValidOk As Boolean
    On Error Resume Next
    ValidOk = ActiveCell.Validation.Formula1 = "=ListAbats"
    On Error GoTo 0
    If Len(ActiveCell.Value) = 0 Or Not ValidOk Then Exit Sub
    Set Cel = [ListAbats].Find(what:=ActiveCell.Value, LookIn:=xlValues)
    Sh.Hyperlinks.Add Anchor:=ActiveCell, Address:=Cel.Hyperlinks(1).Address
    ActiveCell.Hyperlinks(1).SubAddress = Cel.Hyperlinks(1).SubAddress
End Sub

Ce code est répété plusieurs fois en modifiant le nom (SheetChange) et le nom de la plage de cellules (ListAbats).

Merci d'avance de votre aide

Bien cordialement

Bonjour pierrev, toutes et tous,

Je ne sais pas je pourrai t'aider, mais si ton fichier n'a pas de données confidentielles (sinon mettre des données bidons et garder la structure du fichier), le mieux serai de le joindre à ton message.

Cordialement.

Bonsoir Lcntrcld et bonsoir à tous,

Merci de m'avoir répondu.

Pour le fichier, j'avais penser le joindre, mais il fait plus de 80 kb.

Peut-être sur ton mail !

Je donne le mien si cela peut-être utile.

pierrev@windowslive.com

Encore merci de ton aide.

Bien cordialement

Pierrev

Salut le Forum

Oups, désolé je vois que LCNTRCLD t'a déjà répondu.

Erreur 

Mytå

Bonjour pierrev,

Salut Mytå,

Je suis désolé Pierre, mais je ne donne plus mon adresse mail, car trop de déception et retour sur expérience.

Une autre solution essai de passer par http://www.cjoint.com/ tu clique sur ce lien, tu suis les instructions et ensuite tu colle le lien avec ton message.

Si tu arrive à faire ça, alors Mytå dont je connais sa grande compétence en VBA, pourra t'aider.

Cordialement.

Bonjour Lcntrcld et bonjour à Mytå,

Merci à tous les deux de votre gentillesse à me dépanner.

Le fichier se trouve à l'adresse http://www.cjoint.com/c/GArf0TE8hpq.

Il ne comporte que des données publiques qui concernent la nutrition.

Intéressant cette façon de partager un fichier !

Merci encore à vous 2

Re Pierre,

Je suis désolé, mais je n'arrive pas a télécharger ton fichier, sans doute dû à ma version d'Excel (2007 & 2010)

Mytå le pourra peut-être.

Cdlt.

Rebonjour Lcntrcld,

Bizarre, le clic sur le lien de téléchargement:

• Il me propose d'ouvrir le fichier et boom! impossible d'ouvrir le fichier
• Après un nouveau clic sur le lien, je choisis d'enregistrer le fichier sur le bureau et un petit double clic après, il est ouvert.

Les mystères de l'informatique sans doute !

Bien cordialement

Bonjour à tous,

J'ai trouvé un code qui fonctionne avec des liens hypertexte qui renvoient sur des pages Internet ou vers des fichiers.

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$A$11" Then
    ActiveSheet.Hyperlinks.Add Anchor:=Target, Address:=Target.Value, TextToDisplay:=Target.Value
  End If
End Sub

Malheureusement, ce code ne permet pas de sélectionner la cellule d'une autre feuille.

Je joins le fichier comme exemple.

Peut-être une idée de solution!

Bien cordialement à tous

Bonjour pierrev, Lcntrcld, Mytå,

Le code de Didier a été copié dans diverses procédures de ThisWorkbook, malheureusement ces procédures, au nombre de 32(!!) sont inopérantes et ne sont jamais déclenchées...

• Private Sub Workbook_SheetChange38
• Private Sub Workbook_SheetChange15
• ...
• Private Sub Workbook_SheetChange24_3

Seule la procédure Private Sub Workbook_SheetChange est active. Mais celle-ci portait à l'origine la contrainte : ActiveCell.Validation.Formula1 = "=ListAbats". Voilà pourquoi seule cette liste est prise en compte.

J'ai modifié la procédure pour prendre en compte toutes les listes et pas seulement ListAbats.

'-------------------------------------------------------------------------
Option Explicit

' Procédure : Workbook_SheetChange
' Auteur    : Guy Courville
' Date      : 2017-01-18
'
' Référence : Didier FOURGEOT (monCherAmi!)
'             2006-03-06
'
' Détails   : Modification de la procédure pour tenir compte de listes multiples.
'
'-------------------------------------------------------------------------
'
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

  Dim ValidOk As Boolean
  Dim ChainePlageCible As String ' Porte la chaîne de caractères du nom de la plage ciblée.
  Dim PlageCible As Range        ' Porte la plage ciblée.
  Dim CelluleCible As Range      ' Porte la cellule ciblée.
  
  On Error Resume Next
  ChainePlageCible = Target.Validation.Formula1 ' Chaîne sous la forme "=Toto"
  ChainePlageCible = Right(ChainePlageCible, Len(ChainePlageCible) - 1) ' Chaîne précédente privé de "=" : "Toto"
  
  Set PlageCible = Range(ChainePlageCible) ' La plage ciblée est prise en référence.
  
  ValidOk = (Err.Number = 0) ' Est valide si l'erreur est à zéro.
  
  On Error GoTo 0
  If Len(Target) = 0 Or Not ValidOk Then Exit Sub
  
  Set CelluleCible = PlageCible.Find(what:=Target.Value, LookIn:=xlValues) ' La cellule ciblée est prise en référence.
  
  On Error Resume Next
  
  Sh.Hyperlinks.Add Anchor:=Target, Address:=CelluleCible.Hyperlinks(1).Address ' Le lien de CelluleCible est ajouté
  If Err.Number > 0 Then
    MsgBox "La CelluleCible ne porte aucun lien", vbInformation, "Oups, il manque quelque chose!"
    Exit Sub
  End If
  
  On Error GoTo 0
  Target.Hyperlinks(1).SubAddress = CelluleCible.Hyperlinks(1).SubAddress
  
End Sub

Il faudra sûrement peaufiner mais je t'invite à tester la chose et à nous tenir au courant des résultats.

À noter la directive Option Explicit à ajouter à toutes les en-têtes de module. Plus là-dessus sous peu.

Cordialement,

Guy