VBA: Attribuer un hyperlien avec le contenu de la cellule
5 réponses
Emile63
Bonjour =E0 tous,
J'ai des feuille excel servant =E0 des faire de tests qui sont stock=E9s da=
ns un r=E9pertoire: "\Tests\
(dont j'extrais le nom et chemin complet dans un classeur r=E9capitulatif s=
=E9par=E9)=20
Puis quand le test est termin=E9, ces classeurs sont d=E9plac=E9s dans un r=
=E9pertoire: "\Tests termin=E9s\"
Dans la classeur r=E9capitulatif, J'aimerais bien attribuer le lien hyperte=
xte =E0 la cellule qui contient le chemin complet & nom de fichier de celui=
-ci.=20
Le probl=E8me c'est que si depuis la derni=E8re fois, le classeur de test =
=E0 =E9t=E9 d=E9plac=E9 dans le r=E9pertoire test termin=E9e, le lien en qu=
estion ne fonctionnera plus.
Je souhaiterais donc contr=F4ler d'abord si lien il y a, si non le cr=E9=E9=
e selon son nom (de la cellule), et contr=F4ler si ce lien est valide.=20
Si invalide, lui changer le nom de r=E9pertoire dans la cellule et re-cr=E9=
er un nouveau lien avec cette nouvelle adresse.
Je ne sais pas si je me suis fait comprendre (mais je l'esp=E8re), =E0 tout=
hasard, je pose ci-apr=E8s ce bout de code (tr=E8s 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 =3D Range("R4:R" & Rows.Count)
If N > 0 Then
For I =3D N To 1 Step -1
=20
For Each C In Selection
If C.Hpk.Count =3D 1 Then GoTo Fin
ActiveSheet.Hpk.Add Anchor:=3DC, Address:=3DC.Value, TextToDispla=
y:=3D"Ouvrir fichier"
If ActiveCell.VerifHyperlink =3D False Then
strLien =3D Hpk.Address
Hpk.Address =3D Replace(strLien, "\Tests\", "\Tests termin=
=E9s\")
End If
Next C
=20
If Cells(x, 1) =3D Empty Then Exit For
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
MichD
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 '------------------------------------------------
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
'------------------------------------------------
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
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 ----------------------------------------
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
----------------------------------------
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
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
---------------------------------------------
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
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
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!
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!
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!
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
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
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
