XL 2016 Validation des données en gardant les liens hypertextes

Ben92290

XLDnaute Nouveau
Bonjour,

Mon classeur contient deux feuilles, feuille 1 : "Inventaire parc" et feuille 2 "pièces et intervention".

Dans la feuille 2 "pièces et intervention", colonne H, ligne 6 à 39, j'aimerai créer un menu déroulant dans chaque cellule via la validation des données" (liste) en prenant comme source les lignes 8 à10 (mais qui peut aller jusqu'à 50) de la colonne B de la feuille 1 "inventaire parc".

Je n'ai pas de problème pour créer mon menu déroulant avec utilisant la validation de donné mais les liens hypertextes des cellules B8 B9 et B10 de la feuille 1 ne "suivent" pas en H6 de la feuille 2 par exemple.

En gros, j'ai bien les données dans ma feuille 2 par rapport à la feuille 1 mais pas les liens hypertextes qui vont avec.

Merci de votre aide
 

Pièces jointes

  • Copie de SUIVI PARC AUTO.xlsm
    64.8 KB · Affichages: 10

fanch55

XLDnaute Barbatruc
Bonsoir,
Remplacez la procédure de la feuille "Inventaire parc"
Nota: vous y aviez déjà tout pour faire ce que vous demandiez mais pour une autre colonne
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Ip As Worksheet, Cel As Range, H As Range
    Set Ip = Worksheets("Inventaire parc")
    For Each Cel In Target
        If Not Intersect(Cel, Me.[H6:H39]) Is Nothing Then
            Cel.Hyperlinks.Delete
            If Cel <> "" Then
                Set H = Ip.Columns("B").Find(Cel, Ip.[B7])
                If Not H Is Nothing _
                Then Me.Hyperlinks.Add Cel, H.Hyperlinks(1).Address, H.Hyperlinks(1).SubAddress
            End If
        End If
    Next
End Sub
Attention: en B10, l'immatriculation renvoie vers une autre ( inversion de lettres dans l'hyperlien)
 

fanch55

XLDnaute Barbatruc
Si c'est le même processus pour la colonne A :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Ws As Worksheet, Cel As Range, H As Range, Lr As Long
   ' dernière ligne renseignée de la colonne A
    Lr = Me.Columns("A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    For Each Cel In Target
        Select Case True
          Case Not Intersect(Cel, Me.Range("A6:A" & Lr)) Is Nothing
              Cel.Hyperlinks.Delete
              If Cel <> "" Then
                 ' Partie à adapter ------------------------
                  Set Ws = Worksheets("Inventaire parc")
                ' on cherche la valeur de Cel dans la colonne B de la feuille WS après la cellule B7
                  Set H = Ws.Columns("B").Find(Cel, Ws.[B7])
                 ' -----------------------------------------
                  If Not H Is Nothing _
                  Then Me.Hyperlinks.Add Cel, H.Hyperlinks(1).Address, H.Hyperlinks(1).SubAddress
              End If
          Case Not Intersect(Cel, Me.Range("H6:H" & Lr)) Is Nothing
              Cel.Hyperlinks.Delete
              If Cel <> "" Then
                  Set Ws = Worksheets("Inventaire parc")
                  Set H = Ws.Columns("B").Find(Cel, Ws.[B7])
                  If Not H Is Nothing _
                  Then Me.Hyperlinks.Add Cel, H.Hyperlinks(1).Address, H.Hyperlinks(1).SubAddress
              End If
        ' Case blablabla
        '     ...................
        '     ...................
          Case Else
        '     ...................
        '     ...................
        End Select
    Next
 
Dernière édition:

job75

XLDnaute Barbatruc
Avec un code voisin de celui d'origine :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, Union(Columns("A"), Columns("H")), Me.UsedRange)
If Target Is Nothing Then Exit Sub
Dim F As Worksheet, i As Variant, h As Hyperlink
Set F = Sheets("Inventaire parc")
Target.Hyperlinks.Delete 'RAZ
For Each Target In Target 'en cas d'entrées multiples
    i = Application.Match(Target, F.Columns(2), 0)
    If IsNumeric(i) Then
        Set h = F.Cells(i, 2).Hyperlinks(1)
        Me.Hyperlinks.Add Target, h.Address, h.SubAddress 'crée le lien
    End If
Next
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
313 283
Messages
2 096 807
Membres
106 751
dernier inscrit
Souleymani