XL 2016 Bonsoir, je suis à la recherche d'un code qui me permettrait d'ouvrir un chemin reseau et de me renvoyer le lien hypertext sur le texte de la cellule.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim MonDossier As String

If Not Application.Intersect(Target, Range("C18:C57")) Is Nothing Then

MonDossier = "L:\1. Sécurité & Environnement\Accidents & analyse 5 pourquoi et arbres des causes\2020" '<-- adaptez le nom du Dossier

If Len(Dir(MonDossier, vbDirectory)) > 0 Then '---vérifie si le dossier existe---
   Shell Environ("WINDIR") & "\explorer.exe " & MonDossier, vbNormalFocus

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="file://" & fichier
End If
End If


'End If


'ChDir "L:\1. Sécurité & Environnement\Accidents & analyse 5 pourquoi et arbres des causes\2020\"
'ChDir "c:\Users\Christophe\Desktop\" '---chemin d'accès aux fichiers à la maison---

'If Not Application.Intersect(Target, Range("C18:C57")) Is Nothing Then

    'fichier = Application.GetOpenFilename()
    'If fichier <> False Then
    'MsgBox "Insertion du fichier " & fichier, vbOKOnly, "Confirmation"
    'Else: MsgBox "Création du lien annulé", vbOKOnly, "Confirmation": End
    'End If
    'ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="file://" & fichier


End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim MonDossier As String, MonFichier As String
  If Not Application.Intersect(Target, Range("C18:C57")) Is Nothing Then
    MonDossier = "L:\1. Sécurité & Environnement\Accidents & analyse 5 pourquoi et arbres des causes\2020" '<-- adaptez le nom du Dossier
    ' Vérifier l'anti-skash de fin
    If Right(MonDossier, 1) <> "\" Then MonDossier = MonDossier & "\"
    ' Vérifier l'existence du dossier, quoi que pas forcément nécessaire
    If Len(Dir(MonDossier, vbDirectory)) > 0 Then
      MonFichier = ChoixFichier(MonDossier, "CHOIX du FICHIER", "*.*,*.*")
      ' S'il s'agit d'un lecteur réseau, inutile de mettre "file://"
      ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=MonDossier & "\" & MonFichier, TextToDisplay:=Selection.Value
    End If
  End If
End Sub

Function ChoixFichier(DefaultPath As String, sTitre As String, Optional sFilter As String)
  ' LE filtre doit être du type : "BdD Communes (*.xlsx), *.xlsx"
  Dim fd As FileDialog, TabFilter() As String
  ' Initialiser les variables
  If Right(DefaultPath, 1) <> "\" Then DefaultPath = DefaultPath & "\"
  ' Initialiser l'intance du dialogue
  Set fd = Application.FileDialog(msoFileDialogFilePicker)
  With fd
    .Filters.Clear
    ' Si un filtre a été donné
    If sFilter <> "" Then
      TabFilter = Split(sFilter, ",")
      .Filters.Add TabFilter(0), Trim(TabFilter(1))
    End If
    .Title = sTitre
    .InitialFileName = DefaultPath & TabFilter(0)
    If .Show = -1 Then
      ChoixFichier = fd.SelectedItems(1)
    End If
  End With
  Set fd = Nothing
End Function

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [C18:C57]) Is Nothing Then Exit Sub
Dim chemin$, fichier$
Cancel = True
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
Target(1, 2).Clear 'RAZ
fichier = Dir(chemin & Target & ".xls*")
If fichier <> "" Then Target(1, 2).Hyperlinks.Add Target(1, 2), chemin & fichier, TextToDisplay:=fichier
End Sub

fichier = Dir(chemin & Target & ".xls*")

fichier = Dir(chemin & Target & ".xlsx")

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C18:C" & Rows.Count)) Is Nothing Then Exit Sub
Dim chemin$, fichier$
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
Application.ScreenUpdating = False
For Each Target In Intersect(Target, Range("C18:C" & Rows.Count)) 'si entrées ou effacements multiples
    Target(1, 2).Clear 'RAZ
    fichier = Dir(chemin & Target & ".xls*")
    If fichier <> "" Then Target(1, 2).Hyperlinks.Add Target(1, 2), chemin & fichier, TextToDisplay:=fichier
Next
End Sub