Re: Liens hypertexte dans des listes déroulantes |
Titre du sujet : Re: Liens hypertexte dans des listes déroulantes par Guy le 18/01/2017 16:21:57 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...
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 |
Forums