Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

XLDnaute Occasionnel
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.
 
Solution
C
Re,

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

Voici
VB:
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...

christ77000

XLDnaute Occasionnel
Bonjour, j'ai bricoler ce code. j'ai bien le double clic dans les bonnes cellules. J'ai bien l'ouverture de l'explorer et sur le bon répertoire mais je n'ai plus les liens. Pourriez vous m'aider pour ce qui ne va pas. Merci pour votre aide.

VB:
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
 
C

Compte Supprimé 979

Guest
Bonjour Christ77000

Si j'ai bien tout compris (pas simple) voici le code
VB:
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

A+
 

christ77000

XLDnaute Occasionnel
Bonsoir et merci pour votre aide, je pense que le code ne fonctionne pas correctement. quand je quitte par la croix sur l'explorer il me renvoie le lien hypertext de l'accès au repertoire "L:\1. Sécurité & Environnement\Accidents & analyse 5 pourquoi et arbres des causes\2020" sans rien d'autre. Si je fais annuler il me dit erreur d'exécution 5 et argument ou appel de procédure incorrect.
Et plus tard dans la nuit je me suis rendu compte que les liens ne fonctionnent pas. ils sont doublés. cela marque deux fois L:\1. Sécurité & Environnement\Accidents & analyse 5 pourquoi et arbres des causes\2020\L:\1. Sécurité & Environnement\Accidents & analyse 5 pourquoi et arbres des causes\2020\test\test.xls et 1 fois le nom du fichier sans le .xls et le deuxième, ok.
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour christ77000, BrunoM45,

Puisque l'on connaît le nom du fichier et son chemin d'accès inutile d'ouvrir une boîte de dialogue.

Téléchargez les fichiers joints dans le même dossier et voyez cette macro dans Classeur(1).xlsm :
VB:
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
Le lien hypertexte est créé en colonne D.

Bonne journée.
 

Pièces jointes

  • Dossier.zip
    289.4 KB · Affichages: 10

job75

XLDnaute Barbatruc
De toute façon en supposant qu'il existe les fichiers MonFichier01.xlsx et MonFichier01.xlsm l'utilisateur doit savoir a priori lequel il veut utiliser, par exemple MonFichier01.xlsx.

Il suffit donc dans la macro de remplacer :
VB:
fichier = Dir(chemin & Target & ".xls*")
par :
VB:
fichier = Dir(chemin & Target & ".xlsx")
 
C

Compte Supprimé 979

Guest
Job75, je ne l'ai pas lu du tout comme ça

Pour moi, il y a un dossier réseau, contenant des fichiers et on doit pouvoir sélectionner celui que l'on veut en fonction de la valeur d'une cellule entre C17 et C58

Bref, nous n'avons pas le même code, car nous n'avons pas lu/vu la même chose

Porte toi bien et au plaisir
 

job75

XLDnaute Barbatruc
Une variante dans le fichier (2) avec des listes de validation en colonne C :
VB:
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
 

Pièces jointes

  • Dossier.zip
    290.4 KB · Affichages: 6

christ77000

XLDnaute Occasionnel
Bonjour et merci de vos penchez sur mon problème,
Pour moi, il y a un dossier réseau, contenant des fichiers et on doit pouvoir sélectionner celui que l'on veut en fonction de la valeur d'une cellule entre C17 et C58
oui pour la sélection x document et non en fonction de la valeur. je vous joint un imprime écran de la feuille ou il y a les saisies


pour le lien afficher, c'est moi qui l'ai changer pour travailler sur le fichier chez moi. Et les liens ne vont que sur des fichiers .xls, xlsm, xlsx et .pdf.
 
Dernière édition:
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…