Macro pour créer liens hypertextes...

[Christian0258]

Bonjour à tout le forum,

Je souhaiterais votre aide pour me dire pourquoi cette macro ne fonctionne que partiellement…?

voir fichier joint

Merci pour votre aide si précieuse.

Bien à vous,
Christian

 

[job75]

Bonjour Christian0258,

Le plus simple :

Sub CreerLiens()
Dim chemin$, c As Range
chemin = ThisWorkbook.Path & "\Dossier PDF\_" 'avec tiret bas
With Sheets("Archives")
    For Each c In Intersect(.Range("P3:P10000"), .UsedRange)
        If c <> "" Then If Dir(chemin & c) <> "" Then .Hyperlinks.Add c(1, 2), chemin & c, TextToDisplay:=c.Text
    Next
End With
End Sub

Mais pourquoi diable avoir mis un tiret bas devant les noms des fichiers PDF ?

Fichier et dossier joints à placer dans le même répertoire.

A+

 

[Christian0258]

Re, le forum, job75

A nouveau merci, job75, pour ton code, c'est parfait…

Bien à toi,
Christian

Pour le tiret bas, c'est dû à ce code que je n'ai pas su adapter...lol

Dim LeParcours As String, LeRep As String
LeParcours = Range("AM16").Value
LeRep = ThisWorkbook.Path & "\Dossier PDF\"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
LeRep & "_" & LeParcours & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
From:=1, To:=1, OpenAfterPublish:=False

 

[job75]

Re,

C'est bien ce que je pensais, du travail baclé, au lieu de :

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
LeRep & "_" & LeParcours & ".pdf"

il suffisait d'écrire :

If LeParcours <> "" Then ActiveSheet.ExportAsFixedFormat xlTypePDF, LeRep & LeParcours

Et si tu as 1000 fichiers PDF avec un tiret tu sauras les renommer j'espère ?

A+

 

[Christian0258]

Re, le forum, job75

Merci pour la ligne de code à corriger, je vais l'insérer…
Oui pour renommer les fichiers, je saurais faire...lol

Bien à toi, merci pour tout.

Christian

 

[Christian0258]

Re, le forum, job75,

Je reviens vers vous car j'ai inséré la correction, de job75 post 4, mais rien n'est enregistré dans "Dossier PDF".
J'ai sûrement mal fait la correction de job75 ?

le code final ;

Dim LeParcours As String, LeRep As String
LeParcours = Range("AM16").Value
LeRep = ThisWorkbook.Path & "\Dossier PDF\"
If LeParcours <> "" Then ActiveSheet.ExportAsFixedFormat xlTypePDF, LeRep & LeParcours, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
From:=1, To:=1, OpenAfterPublish:=False

Merci pour votre aide.

Bien à vous,
Christian

 

[job75]

Bonjour Christian, le forum,

AM16 ne doit pas être vide...

Bonne journée.

 

[Christian0258]

Re, le forum, job75,

OK, merci job75, c'était bien AM16 le problème, du coup dans ta macro pour créer les liens vers "Dossier PDF" il faut enlever le tiret sur cette ligne de commande ???;

chemin = ThisWorkbook.Path & "\Dossier PDF\_" 'avec tiret bas

A vous lire, bien à vous,

Encore merci, job75.

Bien amicalement,
Christian

 

[job75]

Re,

c'était bien AM16 le problème, du coup dans ta macro pour créer les liens vers "Dossier PDF" il faut enlever le tiret sur cette ligne de commande ???;

chemin = ThisWorkbook.Path & "\Dossier PDF\_" 'avec tiret bas

Oui bien sûr puisqu'il n'y a plus de tiret.

Cela dit si tu as créé beaucoup de fichiers avec tiret les recréer un par un sera très pénible.

Pour ôter le tiret des fichiers existants tu peux utiliser l'une de ces 2 macros :

Sub OterTiret1()
Dim chemin$, fichier$
chemin = ThisWorkbook.Path & "\Dossier PDF\"
fichier = Dir(chemin & "_*.pdf") '1er fichier, avec tiret bas
While fichier <> ""
    If fichier <> "_.pdf" Then Name chemin & fichier As chemin & Mid(fichier, 2) 'renomme
    fichier = Dir
Wend
End Sub

Sub OterTiret2()
Dim chemin$, f As Object
chemin = ThisWorkbook.Path & "\Dossier PDF\"
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(chemin).Files
    If f.Name Like "_?*.pdf" Then Name chemin & f.Name As chemin & Mid(f.Name, 2) 'renomme
Next
End Sub

A+

 

[Christian0258]

Re, le forum, job75,

Ok pour le tiret.

Super, merci beaucoup, pour les macros "oter les tirets", effectivement il y en avait déjà un bon paquet...lol

Merci pour tout.

Bien à toi,
Christian