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

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

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

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