Création PDF en Boucle

Le 18/08/2017 à 20:22
25boucle-pdf.xlsx (14.60 Ko)

Bonjour,

Je souhaite créer une boucle qui fera un PDF pour chaque nom de ma grille.

Chaque PDF devra aller se déposer dans un répertoire au nom de l'onglet correspondant et au nom de la personne.

Les titres A2:F2 devrait être répété.

Ensuite, un PDF avec A3:F7, un autre A8:F12, ainsi de suite jusqu'à tomber sur une cellule vide en A.

J'ai déjà une macro qui fonctionne pour créer un PDF et des répertoires. Par contre, je ne sais pas comment l'adapter pour mon cas.

Voici ma macro initial:

Sub CreationPDF()

Dim FolderPath As String, count As Integer

'Copie le chemin du dossier d'impression

Path = "G:\VPVSC\Partage\Rapports et statistiques\Gestion de la performance\Intégration affaires\Prépopulation"

Path_DS = Path & "\" & Sheets("Prepop").Range("D13").Value

Path_agent = Path_DS & "\" & Sheets("Prepop").Range("D12").Value

FolderPath = Path_agent & "\*.pdf"

'Créer les dossier s'ils n'existent pas

Set fs = CreateObject("Scripting.FileSystemObject")

If Not fs.FolderExists(Path) Then

fs.createfolder (Path)

End If

If Not fs.FolderExists(Path_DS) Then

fs.createfolder (Path_DS)

End If

If Not fs.FolderExists(Path_agent) Then

fs.createfolder (Path_agent)

End If

Filename = Dir(FolderPath)

Do While Filename <> ""

count = count + 1

Filename = Dir()

Loop

nouveauFichier = Path_agent & "\Agent- " & Sheets("Prepop").Range("d12").Value & "- " & Sheets("Prepop").Range("L7").Value & "- " & count & ".pdf"

'On enregistre le fichier excel en .pdf

Sheets(Array("Prepop", "Résultats")).Select

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nouveauFichier, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

Sheets("ANALYSIS").Activate

Sheets("Prepop").Activate

SendKeys "{Escape}"

End Sub

Est-ce que quelqu'un aurait des suggestions pour m'aider?

Merci

Le 19/08/2017 à 06:19

Bon,jour,

un essai

les fichiers seront stockés sur ton bureau ... reste à adapter le dossier (je te laisse la main)

Sub produire_pdf()

onglet = "Nom gestionnaire"

Sheets("pdf").Select
Sheets("pdf").[A3].Select
i = 3
Do While Sheets(onglet).Cells(i, 1) <> ""
    Sheets(onglet).Select
    Rows(i & ":" & i + 4).Select
    Selection.Copy
    Sheets("pdf").Select
    ActiveSheet.Paste
    nompdf = Environ("USERPROFILE") & "\Desktop\" & Sheets(onglet).Cells(i, 1)
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nompdf & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    i = i + 5
Loop

Sheets(onglet).Select

End Sub
Le 19/08/2017 à 08:04

avec création du répertoire au nom de lo'nglet

directement sous ton USER ... tu peux modifier cette instruction Environ("USERPROFILE")

Sub produire_pdf()

onglet = "Nom gestionnaire"

Sheets("pdf").Select
Sheets("pdf").[A3].Select
i = 3
Do While Sheets(onglet).Cells(i, 1) <> ""
    Sheets(onglet).Select
    Rows(i & ":" & i + 4).Select
    Selection.Copy
    Sheets("pdf").Select
    ActiveSheet.Paste
    creation Environ("USERPROFILE") & "\" & onglet
    nompdf = Environ("USERPROFILE") & "\" & onglet & "\" & Sheets(onglet).Cells(i, 1)
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nompdf & ".pdf", _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    i = i + 5
Loop

Sheets(onglet).Select

End Sub
Sub creation(repertoire As String)
Dim fso As Object
Dim rep As String
Dim tabrep, i%
rep = ""

    Set fso = CreateObject("Scripting.FileSystemObject")
    tabrep = Split(repertoire, "\")
    For i = 1 To UBound(tabrep)
        rep = rep & "\" & tabrep(i)
        If Dir(rep, vbDirectory) = "" Then
            nbdir = nbdir + 1
            fso.CreateFolder rep
        End If
    Next i

End Sub
37boucle-pdf.xlsm (25.69 Ko)
Le 21/08/2017 à 15:39

Merci Steelson pour ta réponse.

J'ai fait le test et j'ai erreur d'exécution 70. Sais-tu comment je pourrais corriger ça ?

Aussi, que veux-tu dire par: peux modifier cette instruction Environ("USERPROFILE") ?

Si je veux créer les PDF ici : "G:\VPVSC\Partage\Rapports et statistiques\Gestion de la performance\" est-ce que je dois remplacer Environ("USERPROFILE" par mon lien ?

Merci de ton aide!

Le 21/08/2017 à 15:42
benibeno a écrit :

J'ai fait le test et j'ai erreur d'exécution 70. Sais-tu comment je pourrais corriger ça ?

/quote]

= permission d'accès refusée ... donc on passe au point suivant qui devrait résoudre

benibeno a écrit :

Si je veux créer les PDF ici : "G:\VPVSC\Partage\Rapports et statistiques\Gestion de la performance\" est-ce que je dois remplacer Environ("USERPROFILE" par mon lien ?

OUI, mais sans le dernier \ (je vérifie)

    creation "G:\VPVSC\Partage\Rapports et statistiques\Gestion de la performance\" & onglet
    nompdf =  "G:\VPVSC\Partage\Rapports et statistiques\Gestion de la performance\" & onglet & "\" & Sheets(onglet).Cells(i, 1)
Le 21/08/2017 à 19:24

Merci pour tes réponses!

Ça fonctionne bien

Le 23/08/2017 à 17:49

Finalement, après avoir rouler à nouveau la macro j'ai encore le même problème.

J'ai essayer d'autres répertoires, mais sans succès. Bizarrement mon code poster plus haut qui créer également des dossier et des PDF fonctionne et il utilise le même principe sans la boucle.

J'ai mis en rouge la partie qui plante:

Sub produire_pdf()

Dim onglet As String

onglet = ActiveSheet.Name

Application.ScreenUpdating = False

Sheets("pdf").Select

Sheets("pdf").[A3].Select

i = 3

Do While Sheets(onglet).Cells(i, 1) <> ""

Sheets(onglet).Select

Rows(i & ":" & i + 4).Select

Selection.Copy

Sheets("pdf").Select

ActiveSheet.Paste

creation "G:\VPVSC\DP Expérience client\DPV\Dossiers Benoit Faucher\" & onglet

nompdf = "G:\VPVSC\DP Expérience client\DPV\Dossiers Benoit Faucher\" & onglet & "\" & Sheets(onglet).Cells(i, 1)

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

Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

i = i + 5

Loop

Sheets(onglet).Select

Application.ScreenUpdating = True

End Sub

Sub creation(repertoire As String)

Dim fso As Scripting.FileSystemObject

Dim rep As String

Dim tabrep, i%

rep = ""

Set fso = New Scripting.FileSystemObject

tabrep = Split(repertoire, "\")

For i = 1 To UBound(tabrep)

rep = rep & "\" & tabrep(i)

If Dir(rep, vbDirectory) = "" Then

nbdir = nbdir + 1

fso.CreateFolder rep

End If

Next i

End Sub

Est-ce possible de contourner le problème ?

Merci !

Le 23/08/2017 à 18:44

Quel est le nom de l'onglet ? ... onglet = ActiveSheet.Name

Le 24/08/2017 à 14:15

C'est le nom du gestionnaire (il pourrait différer dans le temps).

De cette façon ça semble fonctionner, mais je dois créer au préalable les dossiers.

Sub produire_pdf()

Dim onglet As String

onglet = "HALLEE, MELANIE"

Application.ScreenUpdating = False

Sheets("pdf").Select

Sheets("pdf").[A3].Select

i = 3

Do While Sheets(onglet).Cells(i, 1) <> ""

Sheets(onglet).Select

Rows(i & ":" & i + 4).Select

Selection.Copy

Sheets("pdf").Select

ActiveSheet.Paste

nompdf = "G:\VPVSC\DP Expérience client\DPV\Dossiers Benoit Faucher\" & onglet & "\" & Sheets(onglet).Cells(i, 1)

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

Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

i = i + 5

Loop

Sheets(onglet).Select

Application.ScreenUpdating = True

End Sub

Merci pour ton aide.

Le 24/08/2017 à 14:58

ok mais la question que je me pose : y-a-t il des caractères interdits ? essaie de créer un dossier "à la main" directement sous l'explorateur avec ce nom pour voir ...

Rechercher des sujets similaires à "creation pdf boucle"