Copie Coller VBA cellule en conservant lien Hypertexte

[StDonat]

Bonjour
Vu la saison je devrai partir pour Rome! Mais avant une ptite question?
J'ai des cellules qui contiennent des liens hypertextes (lien réalisé par un
clic droit lien hypertexte) vers des fichier (en général des PDF situé à
divers endroits sur mon pc).
Par vba je copie ces cellules pour les coller vers un autres fichier( cet
autre fichier n'étant pas lui-même dans le même repertoire que le fichier que
je copie). Et la le lien hypertexte ne marche plus?
Je souhaiterai donc pouvoir lors de la copie noter dans une variable
l'adress du lien et lors du collage y rajuter ce lien hypertexte avec comme
destination le contenu de la variable!
Ouf! Je me reli, j'espere que vous me comprenais, car je trouve mon poste
bien long pour un simple copier/coller!!
Merci joyeuse Paques

[michdenis]

Bonjour,

Cette macro devrait mettre à jour tous les liens hypertextes
d'une feuille. Attention, la procédure suppose que tous les
liens actuels pointent vers un même répertoire. Ne pas utiliser
cette dernière si la condition précédente est fausse.

'------------------------------------------
Sub test()
Dim Link As Hyperlink
Dim NouveauChemin As String

'Renseigne la variable avec le nouveau
'chemin sans oublier le dernier "\"
NouveauChemin = "c:\Users\Dm\Documents\"

With Worksheets("Feuil") 'Nom Feuille à adapter
For Each Link In .Hyperlinks
t = Split(Link.Address, "\")(UBound(Split(Link.Address, "\")))
Link.Address = Replace(Link.Address, Link.Address, NouveauChemin & t)
Link.TextToDisplay = NouveauChemin & t
Next
End With
End Sub
'------------------------------------------

"StDonat" <StD...@discussions.microsoft.com> a écrit dans le message de groupe de
discussion : D847CAAD-0287-49AD...@microsoft.com...

[StDonat]

Merci Michdenis, je vais tester cela, venant de toi,je suis sur que ça
marchera!
Sauf que ,comme d'hab ma question n'etait pas suffisament précise....
Il me semble que ta solution va renommer tous les liens hypertexte qu'elle
va trouver, si je ne trompe pas:
For each link in.hyperlinks va s'occuper de balayer toutes ma feuille!!
donc si je veux adapter ton code il va me falloir recuperer le lien sans
utiliser for each!
est il possible de faire cela?
merci

[michdenis]

| est il possible de faire cela?

Bien sûr. La question est plutôt de savoir ce qu'il y a dans
ta feuille comme adresse pour les liens hypertextes et ce que
tu veux obtenir après traitement. Si tu as une grande diversité
de chemin dans tes liens actuels, ce sera plus difficile de les
actualiser avec une seule procédure.

Tu veux le faire manuellement, en utilisant dans le menu
contextuel d'une cellule la commande "modifier le lien hypertexte".

Je le répète, n'utilise pas cette macro si tu as plusieurs types
d'adresse dans ta feuille actuelle... elle n'est pas faite pour cela.

"StDonat" <StD...@discussions.microsoft.com> a écrit dans le message de groupe de

discussion : 49A31A64-3998-48AF...@microsoft.com...

[StDonat]

Ben non je ne veux pas le faire manuellement mais par VBA. Quand je copie, je
récupere le nom du fichier'hypertexte' puis quand je colle j'ajoute un lien
hypertexte avec un chemin et le nom recupéré. Mais la ou je colle il y a deja
des lien hypertexte que je ne veux pas toucher...

[michdenis]

Si c'est possible, utilise le site internet cjoint.com ou
cijoint.fr et publie une petite partie de ta feuille où
tu as des liens hypertextes. Donne ce que doit devenir
la nouvelle adresse du lien.
(supprime toutes informations sensibles)

Pour la prochaine fois...

Généralement, lorsque nous créons des liens hypertextes
ce sont des liens relatifs. Mais Excel nous permet de créer
des liens absolus.
Pour Excel 2007 -
Gros bouton office dans le coin supérieur gauche
Choisir l'item "préparer" dans la liste, à gauche : Propriétés
à gauche, juste en dessous du ruban, un clic sur "Propriété du document"
"options avancées", dans la case hypertexte on peut insérer C:\

La conséquence de ceci, lorsque l'on insère un lien hypertexte dans le
fichier, il enregistre le chemin complet du lien. Le lien est toujours valide.
Si tu dois faire un copier-coller des liens hypertextes vers une feuille du
nouveau classeur, avant d'effectuer le copier-coller, tu définis pour ce fichier
la même propriété que ci-dessus et tu t'exécutes. Les liens hypertextes devraient
être valides. Ça prend quelques secondes lorsque l'on sait ! ;-))

"StDonat" <StD...@discussions.microsoft.com> a écrit dans le message de groupe de

discussion : F551A90B-134B-4DD8...@microsoft.com...

[StDonat]

Je ne pense pas que mon fichier apporte grand chose...
le fichier source se trouve dans :C:\Users\Nouveaux une cellule posséde un
lien hypertexte qui pointe sur:C:\Users\Nouveaux\Controle\2010\toto.pdf

le fichier ou je veux coller ce lien se trouve
dans:C:\Users\Nouveaux\Controle\2010

lorsque je copie dans le fichier source et que je colle dans l'autre fichier
le lien devient:
C:\Users\Nouveaux\Controle\2010\Controle\2010\toto.pdf !!! or je le veux
toujours dans C:\Users\Nouveaux\Controle\2010.
je ne comprends pas pourquoi Excel(2003) me double les repertoires
Controle\2010

Merci

[michdenis]

La procédure copie recrée dans la feuille de destination
du classeur de ton choix, tous les liens hypertextes
dans la feuille d'un autre classeur exactement dans la
même cellule que dans la feuille du classeur source.

Si dans tes liens hypertextes, tu utilises un protocole autre
que HTTP par exemple FTP et il y en a d'autres,
la procédure n'est pas adaptée pour ces autres protocoles
de même que les adresses internet utilisant la valeur
numérique des adresses.

La copie entre le classeur source et le classeur de destination
suppose que les 2 classeurs sont ouverts.

Cette procédure a sûrement besoin d'être testée plus à fond...
Je compte sur toi... ;-)

'---------------------------------------
Sub test()

Dim H As Hyperlink, Adr As String, Pa As String
Dim P As String, A As Integer, B As Integer
Dim X As Integer, Kf As String, Fn As String
Dim Ht As String, Sa As String, AdrCell As String
Dim Va As String, NomClasseurDest As String
Dim NomFeuilleDest As String, St As String
Dim FeuilleSource As String, ClasseurSource As String

'********Variable à définir***************

'Nom onglet Feuille où sont les hypertextes à copier
FeuilleSource = "Sheet1"
'Nom du classeur où sont les hypertextes à copier
ClasseurSource = "Exemple sélection couleur.xls"
'Nom du classeur de destination
NomClasseurDest = "Book2"
'Nom de la feuille destination
NomFeuilleDest = "sheet1"

'*******************************************

Fn = Workbooks(ClasseurSource).FullName
Kf = UBound(Split(Fn, "\"))

With Workbooks(ClasseurSource)
With .Worksheets(FeuilleSource)
For Each H In .Hyperlinks
Ht = H.Address
Sa = H.SubAddress
Sd = H.ScreenTip
AdrCell = H.Parent.Address
Va = .Range(AdrCell)
If Left(UCase(Ht), 4) <> "HTTP" Then
If Left(Ht, 3) Like "?:\" Then
ElseIf Left(Ht, 3) = "..\" Then
Nb = (Len(Ht) - Len(Replace(Ht, "..\", ""))) / 3
If Nb = 1 Then
kp = UBound(Split(Ht, "\"))
For A = 0 To Kf - kp
Pa = Pa & Split(Fn, "\")(A) & "\"
Next
Adr = Replace(Pa & Right(Ht, Len(Ht) - 3), "/", "\")
ElseIf Nb > 1 Then
For A = 0 To Kf - (Nb + 1)
Pa = Pa & Split(Fn, "\")(A) & "\"
Next
Adr = Pa & Right(Ht, Len(Ht) - (Nb * 3))
End If
End If
If Adr = "" Then Adr = Ht
Else
Adr = Ht
End If

'Copie vers la feuille de destination
With Workbooks(NomClasseurDest)
With .Worksheets(NomFeuilleDest)
With .Range(AdrCell)
If Sa <> "" Then
.Hyperlinks.Add anchor:=.Item(1, 1), _
Address:=Adr, SubAddress:=Sa, _
TextToDisplay:=Va
Sa = ""
Else
.Hyperlinks.Add anchor:=.Item(1, 1), _
Address:=Adr, TextToDisplay:=Va
End If
End With
End With
End With
Pa = ""
Adr = ""
Next
End With
End With
End Sub
'---------------------------------------

"StDonat" <StD...@discussions.microsoft.com> a écrit dans le message de groupe de

discussion : D71ACF53-961A-4DD8...@microsoft.com...

[StDonat]

Merci, j’ai réussit à adapter ton code à mon besoin voir ci-dessous :

If ActiveCell.Value = "" Then Exit Sub
Adr = ThisWorkbook.Path & "\" &
Cells.Hyperlinks.Item(Cells.Hyperlinks.Count).Address 'address du lien
hypertexte
Selection.Copy
Windows(nomfichier).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
With Workbooks(nomfichier)
With .Worksheets(nomonglet)
With .Range(ActiveCell.Address)
.Hyperlinks.Add anchor:=.Item(1, 1), Address:=Adr

End With
End With
End With

Next

.Peut tu m’expliquer pourquoi je suis obligé de passé par :

With Workbooks(nomfichier)
With .Worksheets(nomonglet)
With .Range(ActiveCell.Address)
.Hyperlinks.Add anchor:=.Item(1, 1), Address:=Adr

End With
End With
End With

Il me semble que l’écriture ci dessous est la même mais elle ne marche pas
?!:

Workbooks(nomfichier).Worksheets(nomonglet).Range(ActiveCell.Address).Hyperlinks.Add anchor:=.Item(1, 1), Address:=Adr

[michdenis]

| Workbooks(nomfichier).Worksheets(nomonglet).Range(ActiveCell.Address).Hyperlinks.Add
anchor:=.Item(1, 1), Address:=Adr

Pourquoi ta ligne de code ne fonctionne pas...

Ceci ".Item(1, 1)" fait référence à cela :
Workbooks(nomfichier).Worksheets(nomonglet).Range(ActiveCell.Address)
Si tu remplaces .Item(1,1) par ce qui précède, cela devrait fonctionner, mais
cela rend le code lourd, difficile à lire, lent à l'exécution, long à saisir...

Tu devrais t'habituer à utiliser le
With UnObjet

End With

C'est selon moi, la meilleure façon de coder !

"StDonat" <StD...@discussions.microsoft.com> a écrit dans le message de groupe de

discussion : 516C5255-969A-4656...@microsoft.com...