VBA: Attribuer un hyperlien avec le contenu de la cellule

Le
Emile63
Bonjour à tous,

J'ai des feuille excel servant à des faire de tests qui sont stockés da=
ns un répertoire: "Tests
(dont j'extrais le nom et chemin complet dans un classeur récapitulatif s=
éparé)
Puis quand le test est terminé, ces classeurs sont déplacés dans un r=
épertoire: "Tests terminés"

Dans la classeur récapitulatif, J'aimerais bien attribuer le lien hyperte=
xte à la cellule qui contient le chemin complet & nom de fichier de celui=
-ci.

Le problème c'est que si depuis la dernière fois, le classeur de test =
à été déplacé dans le répertoire test terminée, le lien en qu=
estion ne fonctionnera plus.
Je souhaiterais donc contrôler d'abord si lien il y a, si non le créé=
e selon son nom (de la cellule), et contrôler si ce lien est valide.
Si invalide, lui changer le nom de répertoire dans la cellule et re-cré=
er un nouveau lien avec cette nouvelle adresse.

Je ne sais pas si je me suis fait comprendre (mais je l'espère), à tout=
hasard, je pose ci-après ce bout de code (très approximatif) autour de=
quoi je test.

Je vous remercie d'avance pour votre aide,
Cordialement.
Emile


Sub Raffraichir_Hyperliens()
Dim strLien As String, Hpk As Hyperlink, x As Integer, I As Integer, I As I=
nteger

N = Range("R4:R" & Rows.Count)
If N > 0 Then
For I = N To 1 Step -1

For Each C In Selection
If C.Hpk.Count = 1 Then GoTo Fin
ActiveSheet.Hpk.Add Anchor:=C, Address:=C.Value, TextToDispla=
y:="Ouvrir fichier"
If ActiveCell.VerifHyperlink = False Then
strLien = Hpk.Address
Hpk.Address = Replace(strLien, "Tests", "Tests termin=
és")
End If
Next C

If Cells(x, 1) = Empty Then Exit For

Next
Next I
End If
Fin:

End Sub
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
MichD
Le #26390527
Bonjour,

Comme d'habitude, je n'ai rien compris à ta question.

Voici un petit exemple de code que tu devrais adapter toi-même à ta
problématique!

'------------------------------------------------
Sub TEST()
Dim H As Hyperlink, Adr As String, Chemin_Fichier As String
Dim Fichier As String, Chemin As String, C As Range
On Error Resume Next
'Variable pointant sur le lien hypertexte de la cellule A1

With Worksheets("Feuil1")
For Each C In .Range("A1:A10")
Set H = Range("A1").Hyperlinks(1)
If Err = 0 Then
'la cellule contient un lien hypertexte
'Obtenir le chemin du fichier
Chemin_Fichier = H.Address
'obtenir le nom du fichier
Fichier = Split(Chemin_Fichier,
"")(UBound(Split(Chemin_Fichier, "")))
'Isoler le chemin où se retrouve le fichier
Chemin = Replace(Chemin_Fichier, Fichier, "")
'Supprimer le lien hypertexte si besoin
H.Delete
'Créer un nouveau lien hypertexte au besoin
NouveauChemin = X 'insérer le nouveau chemin se terminant
par ""
NouveauFichier = y 'insérer le nouveau nom du fichier au
besoin.
'Recréer le lien hypertexte
C.Hyperlinks.Add C, NouveauChemin & NouveauFichier
Else
'Que faire si la cellule ne contient pas un lien hypertexte
'Efface l'erreur
Err = 0
End If
Next
End With

End Sub
'------------------------------------------------
Emile63
Le #26390560
Bonjour MichD,
Je te remercie pour ton aide et pour ta proposition.
Je reconnais que mon explication n'était pas facile a comprendre. Mais co mme d'habitude, tu as vu juste.
Ton exemple de code m'a bien aidé. Voici l'exécution finale:
(Peut-être pourrait-elle être affinée pour s'exécuter plus rapideme nt)
-------------------------------------------------------
Sub AfficheLesLiensHypertexte()
'Insertions des hyperliens du contenu des cellules
Dim N As Integer, MonTest As Boolean
On Error Resume Next
For Each C In Range("R4", [R65000].End(xlUp))
N = C.Hyperlinks.Count
If N > 0 Then
MonTest = EstValide(C.Hyperlinks(1))
If MonTest Then
GoTo Suite
Else
Chemin_Fichier = C.Value
Fichier = Split(Chemin_Fichier, "")(UBound(Split(Chemin_ Fichier, "")))
Chemin = Replace(Chemin_Fichier, Fichier, "")
NouveauChemin = "R:Comparatifs terminés"
C.Hyperlinks.Add C, NouveauChemin & Fichier, , "Ouvrir fich ier", NouveauChemin & Fichier
End If
End If
If C.Value = "Ancien" Then Err = 0: GoTo Suite
C.Hyperlinks.Add Anchor:=C, Address:=C.Value, TextToDisplay:= C.Value, ScreenTip:="Ouvrir fichier"
If EstValide(C.Hyperlinks(1)) = False Then
Chemin_Fichier = C.Value
Fichier = Split(Chemin_Fichier, "")(UBound(Split(Chemin_ Fichier, "")))
Chemin = Replace(Chemin_Fichier, Fichier, "")
NouveauChemin = "R:Comparatifs terminés"
C.Hyperlinks.Add C, NouveauChemin & Fichier, , "Ouvrir fich ier", NouveauChemin & Fichier
End If
Suite:
Next
Range("R4").Select
Range("R4", Selection.End(xlDown)).Select
End Sub

Function EstValide(Lien As Hyperlink) As Boolean
On Error Resume Next
If Dir(Lien.Address) <> "" Then
If Err <> 0 Then
Err.Clear
If UCase(Left(Lien.Address, 4)) = "HTTP" Then
EstValide = True
Else
EstValide = False
End If
Else
EstValide = True
End If
End If
End Function
----------------------------------------
Emile63
Le #26390650
Bonjour MichD,
La procédure qui fonctionnait bien hier ne fonctionne plus aujourd'hui... :-(

Je crois savoir d'ou vient le problème mais ne sais pas comment y reméd ier:

Quand le le chemin complet (qui se trouve dans une cellule) est converti en hyperlink, et tant que le fichier reste ouvert, ça fonctionne.
Si je ferme le fichier, et le ré-ouvre ultérieurement, alors l'adresse qui était alors dans l'hypertexte se modifie comme suit:
Avant: [ R:TestTests 2015-00301 Tests, Machine.xlsm ] (Rép. en réseau )
Après: [ ../Test/Tests%2015-00301%20Tests,%20Machine.xlsm ]

Du coup la fonction en place pour assurer que le lien est toujours valide r envoie tout en "Err" sans doute due à ce que "Dir" n'identifie plus corre ctement le répertoire, chemin etc..:
----------------------------------------------
Function EstValide(Lien As Hyperlink) As Boolean
On Error Resume Next
If Dir(Lien.Address) <> "" Then
If Err <> 0 Then
Err.Clear
If UCase(Left(Lien.Address, 4)) = "HTTP" Then
EstValide = True
Else
EstValide = False
End If
Else
EstValide = True
End If
End If
End Function

---------------------------------------------
MichD
Le #26390662
Ta version n'est plus installée sur mon ordinateur.

Ce que tu observes, c'est l'adresse absolue du fichier dans ton code,
est transformé en adresse relative. Par conséquent, le lien est valide,
mais lors d'un clic sur le lien, ce dernier n'arrive pas à trouver le
fichier.

Je ne peux pas être très précis dans ma réponse, mais à cette adresse tu
trouveras comme on doit s'y prendre pour Word 2003. Je suppose qu'Excel
doit se comporter de manière similaire...

https://support.microsoft.com/fr-fr/kb/903163

Lis aussi ceci sur la FAQ de Word, Excel doit être similaire!

http://www.faqword.com/index.php/word/faq-word/references/378-comment-mettre-en-absolu-un-lien-hypertexte
Emile63
Le #26390697
Merci MichD pour cette piste.
Je teste l'une des 2 solutions de Microsoft pour convertir en adresse absol ue, qui consiste depuis les propriétés avancées du document, onglet r ésumé, Répertoire Web : à taper un "x".

Et laisse la seconde en stand by, au cas ou ...
Application.DefaultWebOptions.UpdateLinksOnSave = False

Pour l'instant le "x" semble fonctionner :-)

Encore merci pour ton aide
cordialement,
Emile
Publicité
Poster une réponse
Anonyme