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