VBA, déplacer un pdf

Dim.Reichart

XLDnaute Occasionnel
Coucou,
C'est encore moi (quand on aime, on ne compte pas!)
J'ai un souci avec une autre macro.
Cette fois, je veux déplacer les PDF créés avec la macro précédentes (pour ceux qui ont suivis).
Je met un fichier sur lequel je m'entraine par principe, mais ca ne servira pas a grand chose puisque vous n'avez pas les PDF ni les dossiers concernés.
Donc, voici le code, cela devrait être plus utile.
VB:
Option Explicit
Sub test()

Dim Cel As Long, Nom As String, Lien As String, Fich As String, Dest As String
Cel = 1
Nom = Cells(Cel, 1).Value
Fich = ThisWorkbook.Path & Range("a1").Hyperlinks(1).Address
Lien = ThisWorkbook.Path & "\Archives\" & Range("b1") & "\" & Year(Date) & "\"
Dest = Lien & Nom & ".pdf"
'Créer les dossiers et sous dossiers
On Error Resume Next
MkDir (ThisWorkbook.Path & "\Archives")
On Error Resume Next
MkDir (ThisWorkbook.Path & "\Archives\" & Range("b1"))
On Error Resume Next
MkDir (Lien)

FileCopy Fich, Dest
'Kill Fich
'rediriger le lien
ActiveSheet.Hyperlinks.Add anchor:=Cells(Cel, 1), Address:=Dest, TextToDisplay:=Nom
End Sub
La macro se déroule bien, je n'ai pas d'erreur et le lien est renommé sauf que le PDF n'a pas de copie dans le nouveau fichier archive...
J'ai mis la ligne kill en commentaire pour éviter d'avoir a recréer des PDF à chaque essai.
Si vous avez une idée de ce qui ne fonctionne pas, je vous écoute.
Merci d'avance.
 

Pièces jointes

  • Exercice.xlsm
    22 KB · Affichages: 4
Dernière édition:

Dim.Reichart

XLDnaute Occasionnel
Bonjour,
En plaçant msgbox Fich avant la création des dossiers, j'ai pu comparer la chaine de caractères à l'adresse réelle du dossier.
Et il semblerait que Hyperlinks.Address renvoie une adresse avec des / alors que mon adresse dossier contient des \, et que du coup, ça ne fonctionne pas.
Je vais essayer avec Replace pour remettre les \

EDIT: Ca fonctionne, voici le code:
VB:
Option Explicit
Sub test()

Dim Cel As Long, Nom As String, Lien As String, fichier As String, Fich As String, Dest As String
Cel = 1
Nom = Cells(Cel, 1).Value
fichier = Range("a1").Hyperlinks(1).Address
Fich = ThisWorkbook.Path & "\" & Replace(fichier, "/", "\", 1, 2)
Lien = ThisWorkbook.Path & "\Archives\" & Range("b1") & "\" & Year(Date) & "\"
Dest = Lien & Nom & ".pdf"

'Créer les dossiers et sous dossiers
On Error Resume Next
MkDir (ThisWorkbook.Path & "\Archives")
On Error Resume Next
MkDir (ThisWorkbook.Path & "\Archives\" & Range("b1"))
On Error Resume Next
MkDir (Lien)

FileCopy Fich, Dest
Kill Fich
'rediriger le lien
ActiveSheet.Hyperlinks.Add anchor:=Cells(Cel, 1), Address:=Dest, TextToDisplay:=Nom

End Sub
 
Dernière édition:

Discussions similaires

Réponses
1
Affichages
269
Compte Supprimé 979
C

Statistiques des forums

Discussions
311 725
Messages
2 081 940
Membres
101 845
dernier inscrit
annesof