Conserver liens hypertextes macro
Bonjour a tous,
Apres quelques recherches infructueuses sur le sujet, je m'en remets a vous. Je cherche a transferer mes liens hypertextes d'une feuille a une autre en utilisant une macro.
Sur la feuille1 de mon classeur, une premiere macro cree un repertoire a partir de plusieurs dossiers sur Windows. J'importe les noms des fichiers pdf puis je les transforme en liens hypertextes. Jusqu'ici pas de probleme. Ma premiere feuille ressemble a :
Colonne A Colonne B
Ref1234 1234.pdf (dossier 1)
Ref1235 1235.pdf (dossier 1)
Ref1234 1234sup.pdf (dossier2)
Ref1235 1235sup.pdf (dossier2)
Comme vous pouvez le constater ma colonne A est composee de doublons.
Afin de faciliter la lecture de cette feuille, jai realise une seconde macro qui transpose mon tableau dans une seconde feuille de la maniere suivante :
Colonne A Colonne B Colonne C
Ref1234 1234.pdf (dossier 1) 1234sup.pdf (dossier2)
Ref1235 1235.pdf (dossier 1) 1235sup.pdf (dossier2)
Option Explicit
Sub Database2015()
Dim J As Long
Dim I As Integer
Dim K As Long
Dim Indice As Long
Dim Board
Dim Nb As Integer
Application.ScreenUpdating = False
ReDim Board(1 To Range("A" & Rows.Count).End(xlUp).Row - 1, 1 To 2)
Board(1, 1) = Range("A2")
Board(1, 2) = Range("B2")
Nb = 1
For J = 2 To Range("A" & Rows.Count).End(xlUp).Row
For K = 1 To UBound(Board)
If Range("A" & J) = Board(K, 1) Then
For I = 1 To UBound(Board, 2)
If Board(K, I) = "" Then
Board(K, I) = Range("B" & J)
Exit For
End If
Next I
If I > UBound(Board, 2) Then
ReDim Preserve Board(1 To UBound(Board), 1 To UBound(Board, 2) + 1)
Board(K, UBound(Board, 2)) = Range("B" & J)
End If
Exit For
ElseIf Board(K, 1) = "" Then
Nb = Nb + 1
Board(K, 1) = Range("A" & J)
Board(K, 2) = Range("B" & J)
Exit For
End If
Next K
Next J
With Sheets("Database2015")
.Cells.ClearContents
.Range("A2").Resize(Nb, UBound(Board, 2)) = Board
.Range("A1") = "References"
.Range("B1") = "PDF 1"
.Range("B1").AutoFill .Range("B1").Resize(, UBound(Board, 2) - 1), xlFillSeries
.Select
End With
End SubCela fonctionne tres bien, malheureusement je perds les liens hypertexte !
Auriez-vous des idees sur le sujet ?
Je vous remercie et m'excuse pour le manque de ponctuation (clavier qwerty).
Hnt
Bonjour,
On a des idées sur le sujet, bien sûr !
Ceci étant, note pour la prochaine que mettre un fichier à l'appui d'une demande est presque toujours nécessaire, et dans le doute, il vaut mieux commencer par le mettre pour être assuré d'avoir des conseils ciblés.
Ton cas étant bien décrit, le fichier n'est sans doute pas indispensable, par contre ta 2e macro l'est, puisque c'est elle qui est à retoucher.
Tu colles donc cette macro dans un prochain post, et tu n'omets pas de la sélectionner et cliquer sur la balise code de la fenêtre pour nous la rendre plus lisible.
Cordialement.
Bonjour,
En effet, ce sera plus simple avec le code.
Je ne savais pas s'il fallait modifier la premiere macro en rajoutant un code qui permette d'accrocher le lien a la cellule.
OU si on modifie la seconde en important les valeurs de la premiere feuille.
Le code est dans le message initial.
Merci pour votre aide !
Hnt
Ah ! J'ai zappé que l'adresse du lien ne serait pas dans la macro...
Pas grave, tu adapteras. Tu ajoutes donc à la fin (avant le End With) :
For i = 2 To UBound(board) + 1
For j = 2 To 3
If .Cells(i, j) <> "" Then
.Hyperlinks.Add .Cells(i, j), "file:E:\Documents\" & .Cells(i, j).Value
End If
Next j
Next iUne boucle pour balayer tes cellules et rétablir les liens : tu remplaces le chemin que j'ai mis par celui de tes fichiers, et si la cellule contient le nom du fichier, ok ! mais il m'a semblé qu'il y avait autre chose en plus, dans ce cas il faut en extraire le nom.
Cordialement.
Oui j'avais pense a quleque chose du genre mais mes fichiers viennent de dossiers differents......
Je copie la premiere macro afin que vous ayez toutes les informations... malheureusement je ne peux pas inclure le fichier depuis l'endroit ou je me trouve.
Sub Listing2015()
Application.ScreenUpdating = False
Range("A2: H100000 ").ClearContents
[A1] = "References"
[B1] = "PDF"
'Step 1 : import the files from the 1st folder
Source = "X:\HQ\2015\Import" 'Location of the 1st folder to import
I = 2
f = Dir(Source & "\*.pdf") 'Select only the .pdf files
Do While f <> ""
Cells(I, 2) = f 'write the pdf name in the column B
I = I + 1
f = Dir()
Loop
n = I
'Step 2 : import the files from the 2nd folder
Source2 = "X:\HQ\2015\INV+PO TONG" 'Location of 2nd folder to import
J = 2
Do While (Cells(J, 2).Value <> "") 'search for the first empty cell in the column b
J = J + 1
Loop
Cells(J, 2).Select
f = Dir(Source2 & "\*.pdf") 'Select only the .pdf files
Do While f <> ""
Cells(J, 2) = f 'write the pdf name in the column B
J = J + 1
f = Dir()
Loop
o = J
'Step 3 : import the files from the 3nd folder
Source3 = "X:\HQ\2016\Import" 'Location of 3nd folder to import
K = 2
Do While (Cells(K, 2).Value <> "") 'search for the first empty cell in the column b
K = K + 1
Loop
Cells(K, 2).Select
f = Dir(Source3 & "\*.pdf") 'Select only the .pdf files
Do While f <> ""
Cells(K, 2) = f 'write the pdf name in the column B
K = K + 1
f = Dir()
Loop
'Step 4 : separate the references from the names of the files
M = 2
Do While Cells(M, 2) <> ""
Tableau = Split(Cells(M, 2).Value, "-") 'cut the string at the 1st indent
Cells(M, 1).Value = Tableau(0)
M = M + 1
Loop
'Step 5 : change the names (in column B) into links
Dim Link
Selection.End(xlDown).Select
n = I
fin = Selection.Row
For I = 2 To n - 1 'select the rows from Source
Range("b" & I).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Source & "\" & Range("b" & I).Value
Next
For I = n To o - 1 'select the rows from Source2
Range("b" & I).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Source2 & "\" & Range("b" & I).Value
Next
For I = o To fin 'select the rows from Source3
Range("b" & I).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Source3 & "\" & Range("b" & I).Value
Next
End Sub
Jai rajoute des commentaires pour que vous ayez plus de visibilite sur la macro!
Merci !!
Si tu me rajoutes des commentaires en anglais, là ça va me dissuader de poursuivre !
Bon, donc il y a 3 adresses de dossiers différentes. Ça se suit, mais une fois la macro 1 terminée, les limites sont perdues.
Reste 2 solutions :
- définir un second tableau et y récupérer l'adresse du lien en même temps que l'on récupère la valeur de la cellule dans le 1er tableau ; on reprend l'adresse dans ce tableau lors du rétablissement du lien
- procéder par copie et collage, ce qui veut dire cellule par cellule, là le lien sera copié et collé simultanément.
Cordialement.
Merci pour les solutions. J'ai par consequent ajoute la source en colonne C dans ma premiere feuille. \
Ce qui me donne :
Colonne A = References
Colonne B = Liens PDF
Colonne C = Chemin du fichier d'origine
Et si je comprends bien, dans ma seconde macro je dois faire quelque chose du genre :
fin = Selection.Column
For I = 2 To UBound(Board) + 1
For J = 2 To fin
If .Cells(I, J) <> "" Then
if.....
Cells(i,3)= source alors .Hyperlinks.Add .Cells(I, J), Source & "\" & .Cells(I, J).Value
Cells(i,3)= source2 alors .Hyperlinks.Add .Cells(I, J), Source2 & "\" & .Cells(I, J).Value
Cells(i,3)= source3 alors .Hyperlinks.Add .Cells(I, J), Source3 & "\" & .Cells(I, J).Value
.... end if
End If
Next J
Next I
Est-ce bien l'idee ?
D'abord, si tu as mis le chemin en C lors de la création, la distinction source/source2/source3 n'a pas ou plus de signification.
Ensuite dans ta macro 2, compte-tenu de la méthode de constitution du tableau (que tu vas ensuite affecter en bloc), tu dois servir simultanément un nouveau tableau avec la source, aux mêmes emplacements que les valeurs dans le premier tableau.
Enfin, ce 2e tableau te servira à rétablir les liens (en tenant compte du décalage de la première ligne...).
L'adresse du lien doit commencer par "file:", continuer par le chemin que tu as donc dans le tableau, lequel chemin doit se terminer par un \ (sinon en mettre un), et finir par le nom du fichier.