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

[Ben92290]

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

 

[fanch55]

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

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)

 

[Ben92290]

Bonjour Fanch55,

Merci pour ta réponse !
J'en profite, est-ce que je peux faire une autre "procédure" dans la même feuille ?
J'aimerai faire la même chose pour la colonne A de la feuille 'pièce et intervention"
Merci.

 

[fanch55]

Si c'est le même processus pour la colonne A :

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

 

[Ben92290]

Arf, j'ai copié collé la procédure et remplacer ce qui doit l'être mais je n'y arrive pas.
Après je ne suis pas un expert malheureusement.

 

[job75]

Bonjour Ben92290, fanch55,

Remplacez la procédure de la feuille "Inventaire parc"

Il s'agit plutôt de la procédure de la feuille "Pièces et intervention".

A+

 

[fanch55]

Bonjour Ben92290, fanch55,

Il s'agit plutôt de la procédure de la feuille "Pièces et intervention".

A+

Tout à fait, mauvais copier/coller

 

[job75]

Avec un code voisin de celui d'origine :

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

 

[Ben92290]

Ca marche !

Merci!