automatiser les liens hypertexte

[serge]

Bonjour le forum,

Bon je n'y arrive toujours pas. J'ai beau chercher et questionner ce VBA là est encore trop dur pour moi.
Donc je vous poste en pièce jointe un fichier explicant plus clairement ce que j'aimerais sachant que les liens peuvent ouvrir aussi des fichiers excel que word;

Merci pour votre aide

 

[CHti160]

Salut "serge "
re le "FORUM"
je pense que ces derniers temps de nombreuses questions concernant les liens ont été traitées fais donc des recherches sur le Forum rubrique " Faire une recherche" là haut et suis ton post
A+++
Jean Marie

 

[CHti160]

re"serge"
un petit exemple en piece jointe
bonne nuit
A+++
Jean Marie

 

[CHti160]

Salut "serge " bonsoir le "FORUM"
encore moi avec une autre proposition
le but on cherche dans le classeur " X " où sont regroupés les fichiers .xls et .doc ,s'il existe un fichier "alain.xls" et l'on colle un liens .xls s'il existe un fichier roger.doc ont colle un lien .doc dans une plage évolutive.
à voir et surtot à améliorer (espèrons que Didier_mDF passera par là lol)
A+++
Jean Marie

 

[myDearFriend]

Bonsoir Serge, Jean-Marie (Chti160).


Ci-joint un exemple qui fonctionnera si les documents à lier se trouvent dans le même répertoire que ce classeur.
Jean-Marie, je suis parti approximativement sur la même base que toi...

Voici le code utilisé :
Public Sub CreerLiens()
Dim TabTemp As Variant
Dim L As Long
Dim Chemin As String
Dim Fichier As String
With Sheets("Feuil1")
'Supprime les liens existants
.Hyperlinks.Delete
'Charge les données dans un tableau variant temporaire
L = .Range("A65536").End(xlUp).Row
TabTemp = .Range(.Cells(5, 1), .Cells(L, 1)).Value
'Détermine le chemin du dossier
Chemin = ThisWorkbook.Path & "\"
'Pour chaque nom dans la colonne A
For L = 1 To UBound(TabTemp, 1)
'Crée le lien si le fichier (xls ou doc) existe
Fichier = FichierOk(Chemin & TabTemp(L, 1))
If Fichier <> "" Then
.Hyperlinks.Add Anchor:=.Cells(L + 4, 1), Address:=Fichier, _
TextToDisplay:=.Cells(L + 4, 1).Value
End If
Next L
End With
End Sub
Private Function FichierOk(F As String) As String
'Teste fichier xls
FichierOk = F & ".xls"
If Dir(FichierOk) <> "" Then Exit Function
'Teste fichier doc
FichierOk = F & ".doc"
If Dir(FichierOk) <> "" Then Exit Function
'Renvoie rien si ni xls, ni doc
FichierOk = ""
End Function


Cordialement,
Didier_mDF

 

[myDearFriend]

Heu... pour 5000 noms, on peut peut être accélérer un peu la chose en mettant :


Application.ScreenUpdating = False au début et
Application.ScreenUpdating = True à la fin de la procédure CreerLiens()


Cordialement,
Didier_mDF

 

[CHti160]

Salut "Didier".....mDF
je savais..... tu es comme mon "correcteur Lol
et je peux te dire que grâce à toi et aux DEMOS de Thierry@(qui doit être très occupé en ce moment) j'apprends beaucoup.
En plus je sais que tu seras là pour corriger et surtout obtimiser mes bidouilles ,leurs donner de la crédibilité Lol et surtout répondre à la question posée......
Merci pour de la part de tous re Lol et surtout de moi
A+++
Jean Marie