Création d'un code VBA pour extraire plusieurs fichiers PDF Excel

Le 05/11/2025 à 10:23

Bonjour,

Je souhaiterai extraire et enregistrer un fichier PDF pour chaque client (colonne B), le nom du fichier serait celui du numéro du client (toujours en colonne B).

Je suis parti sur le code ci-dessous mais il sort en erreur et je ne comprends pas pourquoi.

Sub ExporterPDF_ParClient_Corrigé_Final()

    ' Déclaration des variables
    Dim wsData As Worksheet
    Dim rngData As Range 
    Dim colClient As Range 
    Dim cell As Range
    Dim clientUnique As Object 
    Dim clientName As Variant
    Dim pdfPath As String
    Dim fileName As String
    Dim lastRow As Long

    ' --- PARAMÈTRES À CONFIGURER ---

    Const SHEET_NAME As String = "Feuil1" 

    ' LIGNE DES EN-TÊTES : VÉRIFIEZ CE NUMÉRO DANS VOTRE FEUILLE EXCEL !
    Const HEADER_ROW As Long = 4 ' Ex: Si les en-têtes sont en ligne 4, mettez 4.

    ' Colonne contenant le nom du client (Colonne C = 3)
    Const CLIENT_COLUMN As Long = 3 

    ' Chemin où les fichiers PDF seront enregistrés (le dossier doit exister)
    pdfPath = "C:\Users\VotreNomUtilisateur\Desktop\PDF_Clients\" ' <--- À CHANGER

    ' --------------------------------

    Set clientUnique = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error GoTo ErrorHandler 

    Set wsData = ThisWorkbook.Sheets(SHEET_NAME)

    ' --- PRÉPARATION : Nettoyage et Détermination de la Plage ---

    ' Retirer tous les filtres existants 
    If wsData.AutoFilterMode Then
        wsData.AutoFilter.ShowAllData
    End If

    ' Déterminer la dernière ligne de données (colonne A ou B, peu importe, juste pour la fin de la plage)
    lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row

    If lastRow < HEADER_ROW Then
        MsgBox "Aucune donnée trouvée après la ligne d'en-tête (" & HEADER_ROW & ").", vbExclamation
        GoTo CleanUp
    End If

    ' Plage rngData pour le filtre, DOIT inclure la ligne d'en-tête
    Set rngData = wsData.Range(wsData.Cells(HEADER_ROW, "A"), wsData.Cells(lastRow, wsData.UsedRange.Columns.Count)) 

    ' Plage colClient pour la collecte, SANS la ligne d'en-tête
    Set colClient = wsData.Range(wsData.Cells(HEADER_ROW + 1, CLIENT_COLUMN), wsData.Cells(lastRow, CLIENT_COLUMN))

    ' 1. COLLECTER LES NOMS DE CLIENTS UNIQUES
    For Each cell In colClient
        If Trim(cell.Value) <> "" Then
            ' Utiliser UCase pour garantir l'unicité des noms de clients (ignore la casse)
            clientUnique(UCase(Trim(cell.Value))) = Trim(cell.Value)
        End If
    Next cell

    ' Créer le dossier s'il n'existe pas
    If Dir(pdfPath, vbDirectory) = "" Then
        MkDir pdfPath
    End If

    ' 2. BOUCLER SUR CHAQUE CLIENT, FILTRER ET EXPORTER

    ' Appliquer le filtre initial sur la plage de données
    rngData.AutoFilter

    For Each clientName In clientUnique.Keys

        ' Filtrer la colonne (Field:=3 car colonne C est la 3ème colonne de la plage A:...)
        ' Le critère est la valeur stockée dans le dictionnaire (pas la clé en majuscules)
        rngData.AutoFilter Field:=CLIENT_COLUMN, Criteria1:=clientUnique(clientName)

        ' --- Préparation du nom de fichier ---

        ' Retirer les caractères illégaux pour un nom de fichier
        fileName = clientUnique(clientName)
        fileName = Replace(fileName, "/", "_")
        fileName = Replace(fileName, "\", "_")
        fileName = Replace(fileName, ":", "_")
        fileName = Replace(fileName, "*", "_")
        fileName = Replace(fileName, "?", "_")
        fileName = Replace(fileName, Chr(34), "_") 
        fileName = Replace(fileName, "<", "_")
        fileName = Replace(fileName, ">", "_")
        fileName = Replace(fileName, "|", "_")

        ' S'assurer que le nom n'est pas trop long
        If Len(fileName) > 150 Then
            fileName = Left(fileName, 150)
        End If

        filePath = pdfPath & fileName & ".pdf"

        ' --- Exportation PDF ---

        ' Exporter SEULEMENT la zone de la feuille qui contient des données
        ' y compris les en-têtes et les données filtrées
        wsData.UsedRange.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=filePath, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=False

    Next clientName

CleanUp:
    ' 4. NETTOYAGE ET FIN

    ' Retirer le filtre final
    If wsData.AutoFilterMode Then
        wsData.AutoFilter.ShowAllData
    End If

    ' Rétablir les paramètres par défaut
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    If Not Err.Number Then
        MsgBox "L'extraction PDF par client est terminée !" & vbCrLf & "Les fichiers se trouvent dans : " & pdfPath, vbInformation, "Terminé"
    End If

    Exit Sub 

ErrorHandler:
    ' Gestionnaire d'erreurs
    MsgBox "Une erreur est survenue (" & Err.Number & ": " & Err.Description & ") au moment de traiter le client : " & clientUnique(clientName) & vbCrLf & _
           "Veuillez vérifier les valeurs de HEADER_ROW et CLIENT_COLUMN.", vbCritical, "Erreur VBA"
    Resume CleanUp ' Continue le nettoyage avant de sortir de la sub
End Sub

Le fichier étant trop lourd pour être partagé je le mets sur Sheets Test - Google Sheets

Merci d'avance

Le 05/11/2025 à 12:11

bonjour Breizhoneig,

ne pouvez-vous pas partagé le fichier avec uniquement la feuille "feuil1" et une vingtaine de lignes (anonymisées)?

Vos données, c'est un tableau structuré ?

Le 05/11/2025 à 12:52

Bonjour,

Il s'agit d'un TCD, entre temps j'ai fait d'autres tests, pour en arriver à ce code

Option Explicit

Sub Imprimer_PDF_Decoupage_Final()

    ' Déclaration des variables
    Dim ws As Worksheet
    Dim dLig As Long              
    Dim startLig As Long          
    Dim endLig As Long            
    Dim currentLig As Long        
    Dim sPath As String           ' Chemin de sauvegarde choisi
    Dim sCli As String            
    Dim sPrevCli As String        
    Dim fldrPicker As FileDialog  ' Objet pour sélectionner le dossier

    ' --- PARAMÈTRES CRUCIAUX ---

    ' Colonne où se trouve le nom du client (Colonne A = 1)
    Const CLIENT_COL As String = "B" 

    ' Ligne à partir de laquelle commence le premier bloc de données client
    ' VÉRIFIEZ CE NUMÉRO DANS VOTRE FEUILLE "Feuil1"
    Const FIRST_DATA_ROW As Long = 11 ' <--- À VÉRIFIER

    ' La dernière colonne que vous souhaitez imprimer (A à AG)
    Const LAST_PRINT_COL As String = "AG" 

    ' ----------------------------

    Set ws = ThisWorkbook.Sheets("Feuil1")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error GoTo ErrorHandler

    ' 1. SÉLECTION DU DOSSIER PAR L'UTILISATEUR
    Set fldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With fldrPicker
        .Title = "Sélectionnez le dossier où enregistrer les fichiers PDF"
        .AllowMultiSelect = False

        If .Show = True Then
            sPath = .SelectedItems(1) & Application.PathSeparator
        Else
            MsgBox "Opération annulée par l'utilisateur. Aucun fichier PDF ne sera créé.", vbExclamation
            GoTo CleanUp ' Sortir si l'utilisateur annule
        End If
    End With

    ' 2. LOGIQUE DE DÉCOUPAGE ET D'EXPORTATION

    With ws
        ' Détermination de la dernière ligne
        dLig = .Range(CLIENT_COL & .Rows.Count).End(xlUp).Row

        ' Initialisation
        sPrevCli = "DEPART_INIT"
        startLig = FIRST_DATA_ROW

        ' Boucle principale : parcourt toutes les lignes de données
        For currentLig = FIRST_DATA_ROW To dLig + 1

            ' Condition : Si la ligne actuelle marque le début d'un nouveau bloc OU est la fin du tableau
            If (Trim(.Range(CLIENT_COL & currentLig).Value) <> "" And .Range(CLIENT_COL & currentLig).Value <> sPrevCli) Or currentLig = dLig + 1 Then

                ' Traitement du BLOC PRÉCÉDENT
                If startLig < currentLig Then

                    endLig = currentLig - 1 

                    ' Récupérer le nom du client du bloc précédent
                    sCli = .Range(CLIENT_COL & endLig).End(xlUp).Value 

                    If Trim(sCli) <> "" And sCli <> "Etablissement" Then

                        ' --- A) DÉFINIR LA ZONE D'IMPRESSION ---
                        .PageSetup.PrintArea = "$" & CLIENT_COL & "$" & startLig & ":$" & LAST_PRINT_COL & "$" & endLig

                        ' --- B) EXPORTATION PDF ---

                        ' Nettoyer le nom du client pour le nom du fichier
                        Dim cleanCli As String
                        cleanCli = Replace(sCli, "/", "_")
                        cleanCli = Replace(cleanCli, "\", "_")
                        cleanCli = Replace(cleanCli, ":", "_")
                        cleanCli = Replace(cleanCli, "*", "_")
                        cleanCli = Replace(cleanCli, "?", "_")
                        cleanCli = Replace(cleanCli, Chr(34), "_")
                        cleanCli = Replace(cleanCli, "<", "_")
                        cleanCli = Replace(cleanCli, ">", "_")
                        cleanCli = Replace(cleanCli, "|", "_")

                        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                Filename:=sPath & cleanCli & ".pdf", _
                                Quality:=xlQualityStandard, _
                                IncludeDocProperties:=True, _
                                IgnorePrintAreas:=False, _
                                OpenAfterPublish:=False

                    End If
                End If

                ' Préparer pour le bloc suivant
                startLig = currentLig
                sPrevCli = Trim(.Range(CLIENT_COL & currentLig).Value)

            End If 

        Next currentLig 

        ' Nettoyage final de la zone d'impression Excel
        .PageSetup.PrintArea = "" 

    End With

CleanUp:
    ' Rétablir les paramètres
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    If Not Err.Number And sPath <> "" Then
        MsgBox "L'extraction PDF par client est terminée !" & vbCrLf & "Les fichiers ont été enregistrés dans : " & sPath, vbInformation
    End If

    Exit Sub 

ErrorHandler:
    ' Gestionnaire d'erreurs
    MsgBox "Une erreur est survenue (" & Err.Number & ": " & Err.Description & ") à la ligne " & currentLig & "." & vbCrLf & _
           "Veuillez vérifier la valeur de FIRST_DATA_ROW.", vbCritical, "Erreur VBA Découpage"
    Resume CleanUp 
End Sub

Cependant, il ne me sort que les sous totaux :/

Le 05/11/2025 à 13:00

re,

c''est un TCD, alors copiez ce TCD (ou les 20 premières lignes) et collez-le "special valeurs" dans un nouveau fichier.

C'est quou exactement l'erreur de cette macro ?

Un TCD est même plus facile à gérer ...

Le 05/11/2025 à 14:04

Le soucis de ce code c'est que le premier client à être extrait est bon, mais le deuxième se cumule avec le premier et ainsi de suite

7test-2.xlsx (19.20 Ko)
Le 05/11/2025 à 16:09

re,

j'ai créé mes propres données + TCD dans la feuille "Blad1" et puis la macro "Imprimer_PDF_Decoupage_Final" crée des pdfs, ce n'est pas encore dans des sous-dossiers.

6test-2-5.xlsb (42.51 Ko)
Sub Imprimer_PDF_Decoupage_Final()
     Dim TCD, i, j, sName

     Application.ScreenUpdating = False

     Set TCD = Sheets("blad1").PivotTables(1)     'votre TCD
     With TCD
          .PivotCache.MissingItemsLimit = xlMissingItemsNone     'supprimer les items qui ne sont plus là
          .ClearAllFilters                   'clear existing filters

          With .PivotFields("Client")        'pour la colonne "Client"
               For i = 1 To .PivotItems.Count     'boucler tous les clients
                    sName = ThisWorkbook.Path & "\" & .PivotItems(i).Name & ".pdf"     'nom du pdf
                    Application.StatusBar = sName: DoEvents     'montrer ce nom dans le "statusbar"
                    .PivotItems(i).Visible = True     'certainement commencer avec montrer cet item
                    For j = 1 To .PivotItems.Count     'puis boucler tous les items
                         .PivotItems(j).Visible = (i = j)     'cacher tous sauf le "i"
                    Next
                    TCD.TableRange1.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sName     'créer le pdf
               Next
          End With

          .ClearAllFilters                   'clear existing filters
     End With

     Application.StatusBar = False
End Sub
Le 05/11/2025 à 19:10

Bonjour,

Je m'insère dans ce fil suivi par BsAlv.

Sans code VBA et à tester sur vos fichiers --> https://forum.excel-pratique.com/astuces/convertir-un-tableau-d-un-fichier-pdf-vers-un-fichier-excel...

Crdlt

Le 06/11/2025 à 09:06

@Dan, c'était Excel vers PDF et pas PDF vers Excel,

Le 06/11/2025 à 09:13

@BsAlv :

Juste ! .... le titre du sujet faisait penser le contraire. Raison de mon post.
J'aurais dû lire les codes avant...

merci

Rechercher des sujets similaires à "creation code vba extraire fichiers pdf"