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.

[christ77000]

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.

Chemin réseau en C1 de ma feuille "GC-2020"
..\..\Accidents%20&%20analyse%205%20pourquoi%20et%20arbres%20des%20causes\2020\

Donnée dans cellule C17:C57

exemple en C17 j'ai le mot "toto" je double clic dans la cellule et j'ai l'ouverture du chemin reseau dans l'explorer. je selectionne le fichier et il me renvoie sur le mot toto le lien hyperlink du fichier.

Merci pour votre aide.

 

[christ77000]

et s'il n'y a rien dans la cellule et que je double clic ca affiche ca

 

[christ77000]

Je viens d'éliminer un des problèmes, enfin je pense. Si je double clic sur une cellule vide. je n'ai plus l'erreur d'exécution 5, mais le lien qui s'affiche.

le premier lien en c32 juste par un double clic sur le fichier et le deuxième si j'annule il reste le lien vers les fichiers. je me suis rendu compte que lorsque je quitte le fichier et le relance et bien le double lien disparaît et qu'il fonctionne ?? la par contre je ne trouve pas de solution car je ne comprends pas tout le code.
du coup j'ai retirer la fin de cette ligne "ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=MonDossier & "\" & MonFichier ', TextToDisplay:=Selection.Value

 

[job75]

Ah mais votre exemple avec "Films" m'éclaire, vous voulez faire une recherche.

Alors téléchargez ces 3 fichiers dans le même dossier (le bureau) et voyez cette macro :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [C18:C57]) Is Nothing Or Target(1) = "" Then Exit Sub
Dim fichier As Variant
Cancel = True
ChDir ThisWorkbook.Path 'dossier à adapter
fichier = Application.GetOpenFilename
If fichier <> False Then If InStr(LCase(fichier), LCase(Target)) Then Target.Hyperlinks.Add Target, fichier, TextToDisplay:=Target.Text
End Sub

 

[christ77000]

Merci pour l'aide, non pas de recherche dans les imprime écrans fournis on nous demande une description succincte, la réponse peut être et en fonction des personnes par exemples. fuite moteur x et le nom du fichier toto.xls. C'est une sorte de rapport électronique de nos problèmes de sécurité et autres. C'est juste une sélection de fichier a mettre en lien hypertexte sur fuite moteur x, tout comme le ferait le clic droit et lien hypertexte. En faite le fuite moteur x devient le nom du lien hypertext vers ce fichier toto.xls.

 

[christ77000]

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.

Chemin réseau en C1 de ma feuille "GC-2020"
..\..\Accidents%20&%20analyse%205%20pourquoi%20et%20arbres%20des%20causes\2020\

Donnée dans cellule C17:C57

exemple en C17 j'ai le mot "toto" je double clic dans la cellule et j'ai l'ouverture du chemin reseau dans l'explorer. je selectionne le fichier et il me renvoie sur le mot toto le lien hyperlink du fichier.

Ce que j'avais expliquer lors de mon tout premier poste

 

[Compte Supprimé 979]

Re,

Le choix du fichier retourne le chemin complet, il suffisait de supprimer le chemin initial

Voici

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim MonDossier As String, MonFichier As String
  Cancel = True ' Evite d'entrée en mode esition dans la cellule
  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", "*.*,*.*")
      ' Si MonFichier n'est pas vide
      If MonFichier <> "" Then
        ' S'il s'agit d'un lecteur réseau, inutile de mettre "file://"
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=MonFichier, TextToDisplay:=Selection.Value
      End If
    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

 

[christ77000]

Le double clic ne fonctionne plus

 

[Compte Supprimé 979]

Le double clic ne fonctionne plus

Ce n'est pas mon code, désolé

 

[christ77000]

Oups, l'erreur venait de moi et de mon chemin d'accès au fichier entre la maison et celui du boulot. Un grand merci a vous pour votre aide. Je testerais ce soir au boulot et vous donnerais la réponse. Bonne soirée et prenez soin de vous et de vos proches.

 

[job75]

Si l'on veut filtrer les fichiers du dossier affiché il faut en effet utiliser Application.FileDialog :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [C18:C57]) Is Nothing Or Target(1) = "" Then Exit Sub
Dim chemin$
Cancel = True
chemin = ThisWorkbook.Path 'dossier à adapter
ChDir chemin
With Application.FileDialog(msoFileDialogFilePicker)
    .InitialFileName = chemin & "\*" & Target & "*"
    .Filters.Clear
    .Filters.Add "Tous les fichiers", "*.*"
    .AllowMultiSelect = False
    If .Show Then Target.Hyperlinks.Add Target, .SelectedItems(1), TextToDisplay:=Target.Text
End With
End Sub

Fichier (2).

 

[christ77000]

Bonjour à tous, tout fonctionne bien. Mes collègues et moi même vous remercions pour avoir donné de votre temps