Discussion :

[aude_alti]

Bonjour,

Ca fait plusieurs jours que je cherche mais je ne trouve pas…de plus je débute en macro VBA.
Je viens donc solliciter votre aide.

A l’aide d’une macro, je souhaiterai fusionner des fichiers pdf 4 par 4 en un fichier pdf, à partir d’une liste excel.
Soit à partir de la liste excel suivante:

patient1_pdf1.pdf
patient1_pdf2.pdf
patient1_pdf3.pdf
patient1_pdf4.pdf
patient2_pdf1.pdf
patient2_pdf2.pdf
patient2_pdf3.pdf
patient2_pdf4.pdf
patient3_pdf1.pdf
patient3_pdf2.pdf
patient3_pdf3.pdf
patient3_pdf4.pdf

J’obtiendrai patient1.pdf, patient2.pdf, patient3.pdf…etc. avec patient1.pdf = fusion de patient1_pdf1.pdf et patient1_pdf2.pdf et patient1_pdf3.pdf et patient1_pdf4.pdf
Dans l’exemple je n’ai reporté que 12 fichiers pdf à fusionner mais au final, j’en aurai environ 600.

Sur le forum, j’ai trouvé le code suivant qui permet de fusionner en 1 fichier pdf tous les fichiers de la liste excel. Il me manque donc une boucle de 4 en 4 que je ne parviens pas à insérer.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Option Explicit
Sub Tst_Fusion()
Dim sDossierPDF As String
Dim sDossierOut As String
Dim sFichierFusion As String
 
    sDossierPDF = ThisWorkbook.Path & "\"
    sDossierOut = ThisWorkbook.Path & "\" & "Test" & "\"
    sFichierFusion = "Fusion.pdf"
 
    FusionPDFs sDossierPDF, sDossierOut, sFichierFusion
End Sub
 
Private Sub FusionPDFs(sPdfDir As String, _
                       sPdfOutDir As String, _
                       sFichierOut As String)
Dim bFirst As Boolean
Dim oPDDoc As Object
Dim oTempPDDoc As Object
Dim LastRow As Long
Dim I As Long
Dim sFichier As String
 
    bFirst = True
    LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    ' Worksheets("PATIENT").Range("A2:E2").Copy Ws.Range("A1:E1")
 
    For I = 1 To LastRow
        sFichier = Feuil1.Range("A" & I)
        If bFirst Then
            bFirst = False
            Set oPDDoc = CreateObject("AcroExch.PDDoc")
            oPDDoc.Open sPdfDir & sFichier
        Else
            Set oTempPDDoc = CreateObject("AcroExch.PDDoc")
            oTempPDDoc.Open sPdfDir & "\" & sFichier
            oPDDoc.InsertPages oPDDoc.GetNumPages - 1, oTempPDDoc, 0, oTempPDDoc.GetNumPages, 1
            oTempPDDoc.Close
        End If
    Next I
 
    With oPDDoc
        .Save 1, sPdfOutDir & "\" & sFichierOut
        .Close
    End With
 
    Set oPDDoc = Nothing
    Set oTempPDDoc = Nothing
End Sub

Merci d’avance pour votre aide qui me sera très précieuse.

aude_alti

[Guiiand]

Bonjour,

Voila qui devrait répondre a tes attentes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Option Explicit
Sub Tst_Fusion()
Dim sDossierPDF As String
Dim sDossierOut As String
Dim sFichierFusion As String
 
    sDossierPDF = ThisWorkbook.Path & "\"
    sDossierOut = ThisWorkbook.Path & "\" & "Test" & "\"
    sFichierFusion = "Fusion.pdf"
 
    FusionPDFs sDossierPDF, sDossierOut, sFichierFusion
End Sub
 
Private Sub FusionPDFs(sPdfDir As String, _
                       sPdfOutDir As String, _
                       sFichierOut As String)
Dim bFirst As Boolean
Dim oPDDoc As Object
Dim oTempPDDoc As Object
Dim LastRow As Long
Dim I As Long
Dim sFichier As String
Dim iLigne As Integer
Dim iNoPatient As Integer
 
    bFirst = True
    LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    iLigne = 1
    ' Worksheets("PATIENT").Range("A2:E2").Copy Ws.Range("A1:E1")
 
 
While iLigne < LastRow
    iNoPatient = iNoPatient + 1
    For I = 0 To 3
        sFichier = Feuil1.Range("A" & iLigne + I)
        If bFirst Then
            bFirst = False
            Set oPDDoc = CreateObject("AcroExch.PDDoc")
            oPDDoc.Open sPdfDir & sFichier
        Else
            Set oTempPDDoc = CreateObject("AcroExch.PDDoc")
            oTempPDDoc.Open sPdfDir & "\" & sFichier
            oPDDoc.InsertPages oPDDoc.GetNumPages - 1, oTempPDDoc, 0, oTempPDDoc.GetNumPages, 1
            oTempPDDoc.Close
        End If
    Next I
 
    iLigne = iLigne + 4
 
    With oPDDoc
        .Save 1, sPdfOutDir & "\" & Left(sFichierOut, Len(sFichierOut) - 4) & iNoPatient & ".pdf"
        .Close
    End With
 
    Set oPDDoc = Nothing
    Set oTempPDDoc = Nothing
Wend
 
End Sub

[aude_alti]

Merci Guiiand pour ta réponse, je la teste et reviens vers toi

Par contre, une chose me chagrine, mon fichier final Fusion.pdf va être écrasé à chaque fois par le nouveau pdf créé. Il faudrai donc que je fasse une boucle avec iNoPatient?

[Guiiand]

Regarde juste au dessous du while, iNoPatient s’incrémente a chaque boucle de 4 i.

Donc normalement, il y aura bien un pdf différent a chaque fois.

[aude_alti]

Guiiand, oui en effet, j'ai bien un premier fichier Fusion1.pdf , par contre ça ne marche que si j'ai 5 pdf dans ma liste, au delà ça buggue et je n'ai pas de Fusion1.pdf. Aurais-tu une idée?

Et je complique un peu la donne , je souhaiterai que mon fichier de sorti, au lieu de s'appeler Fusion1, s'appelle 'les 9 premiers caractères' de patient1_pdf1.pdf, puis Fusion2.pdf s'appelle patient2_pdf1.pdf..etc.
(car en fait 'patient1' de fichier patient1_pdf1.pdf est une chaîne de 9 chiffres)

Merci encore à toi,

aude_alti

[Guiiand]

Re

voici la modif pour les noms des Pdf.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Option Explicit
Sub Tst_Fusion()
Dim sDossierPDF As String
Dim sDossierOut As String
Dim sFichierFusion As String
 
    sDossierPDF = ThisWorkbook.Path & "\"
    sDossierOut = ThisWorkbook.Path & "\" & "Test" & "\"
    sFichierFusion = "Fusion.pdf"
 
    FusionPDFs sDossierPDF, sDossierOut, sFichierFusion
End Sub
 
Private Sub FusionPDFs(sPdfDir As String, _
                       sPdfOutDir As String, _
                       sFichierOut As String)
Dim bFirst As Boolean
Dim oPDDoc As Object
Dim oTempPDDoc As Object
Dim LastRow As Long
Dim I As Long
Dim sFichier As String
Dim iLigne As Integer
Dim iNoPatient As Integer
Dim NomNouveauFichier As String
 
    bFirst = True
    LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    iLigne = 1
 
While iLigne < LastRow
    iNoPatient = iNoPatient + 1
    For I = 0 To 3
        sFichier = Feuil1.Range("A" & iLigne + I)
        If bFirst Then
            bFirst = False
            Set oPDDoc = CreateObject("AcroExch.PDDoc")
            oPDDoc.Open sPdfDir & sFichier
        Else
            Set oTempPDDoc = CreateObject("AcroExch.PDDoc")
            oTempPDDoc.Open sPdfDir & "\" & sFichier
            oPDDoc.InsertPages oPDDoc.GetNumPages - 1, oTempPDDoc, 0, oTempPDDoc.GetNumPages, 1
            oTempPDDoc.Close
        End If
    Next I
 
    'J'ai mis iNoPatient devant pour eviter d'ecraser le patient1_pdf1.pdf original
    NomNouveauFichier = iNoPatient & Feuil1.Range("A" & iLigne)
    iLigne = iLigne + 4
 
    With oPDDoc
        .Save 1, sPdfOutDir & "\" & NomNouveauFichier
        .Close
    End With
 
    Set oPDDoc = Nothing
    Set oTempPDDoc = Nothing
Wend
 
End Sub

Par contre je ne vois pas pourquoi ca bloque à 5 pdf. pourrais tu executer la macro pas a pas et me dire qu est ce qui ne va pas ? Car la je ne vois pas.