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]

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.

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

 

[Compte Supprimé 979]

Bonjour Christ77000

Si j'ai bien tout compris (pas simple) voici le code

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]

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.

 

[Compte Supprimé 979]

Bonjour,

Il suffit d'ajouter des tests et vérifier les valeurs des variables à rectifier

 

[job75]

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 :

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.

 

[Compte Supprimé 979]

Bonjour job75, j'espère que tu te portes bien

Qu'est-ce qui te dit qu'il n'y a qu'un seul fichier, j'ai loupé une info

@+

 

[job75]

Qu'est-ce qui te dit qu'il n'y a qu'un seul fichier, j'ai loupé une info

C'est juste moi qui le suppose car il serait asez bizarre qu'il y ait dans le même dossier plusieurs fichiers portant le même nom (avec des extensions différentes).

Mais c'est vrai que notre ami n'en est pas à une contradiction près...

 

[job75]

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 :

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

par :

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

 

[Compte Supprimé 979]

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]

Une variante dans le fichier (2) avec des listes de validation en colonne C :

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

 

[christ77000]

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.

 

[Compte Supprimé 979]

Salut Christ77000

Bonjour et merci de vos penchez sur mon problème,
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
Regarde la pièce jointe 1061602
pour le lien afficher, c'est moi qui l'ai changer pour travailler sur le fichier chez moi

C'est donc ce que fait mon code ;-)

@+

 

[christ77000]

le premier code oui mais le lien est en double sur le chemin du répertoire

la je montre la manipe avec un exemple

 

[christ77000]

et la le résultat

 

[christ77000]

la si j'annule par la croie sur l'explorer le lien du répertoire alors que normalement il ne devait rien y avoir. Et la même chose si j'annule.