XL 2019 Extraction de Données dans fichier PDF

[Caninge]

Bonjour à tous,

j'ai utilisé ce fichier EXCEL pour extraire des données d'une feuille EXCEL sur des fichiers PDF.
Je fais un copier coller d'un autre fichier EXCEL comme dans mon exemple et ensuite la procédure crée 2 Fichiers PDF.
Mais voilà ca Bugue.
Pouvez-vous me dépanner s'il vous plait ?
Merci

 

[Franc58]

Bonjour, quand tu vas chez le médecin, tu dis juste "docteur je suis malade" ou tu donnes quelques détails pour aider au diagnostic ?

 

[Caninge]

Bonjour Franc58,

oui effectivement tu as raison.
Si je clique sur Imprimer la sélection ou bien sur Imprimer Tout la procédure Bugue sur cette ligne :

.Range(.Rows(8), .Columns(2).Find("Observation*", , xlValues)(0)).Delete 'RAZ

 

[job75]

Bonjour,

et ensuite la procédure crée 2 Fichiers PDF.

Dans le fichier Excel le code ne crée aucun PDF.

A+

 

[Caninge]

Bonjour Job75,
en principe quand la procédure est terminée la page IMPRIMER s'ouvre et je choisis PDF

 

[job75]

Si je clique sur Imprimer la sélection ou bien sur Imprimer Tout la procédure Bugue sur cette ligne :

.Range(.Rows(8), .Columns(2).Find("Observation*", , xlValues)(0)).Delete 'RAZ

Bah dans la feuille "Imprimante" le texte "Observation" n'existe pas...

 

[Franc58]

Bonjour Franc58,

oui effectivement tu as raison.
Si je clique sur Imprimer la sélection ou bien sur Imprimer Tout la procédure Bugue sur cette ligne :

.Range(.Rows(8), .Columns(2).Find("Observation*", , xlValues)(0)).Delete 'RAZ

A mon avis ça vient de .Find("Observation*", dans le cas où "Observation*" n'est pas trouvé, tu auras une erreur. Tu peux gérer l'erreur comme ceci:

Sub Imprimer(choix As Boolean)
    Dim r As Range, P As Range, n&, c As Range
    Dim foundCell As Range
    Set r = Range("B3:B" & Rows.Count)
    
    ' Si le tableau est vide, sortir de la macro
    If Application.CountA(r) = 0 Then Exit Sub
    
    ' Si l'utilisateur a fait un choix de sélection
    If choix Then
        ActiveCell.Activate ' Au cas où la sélection est un objet
        Set r = Intersect(Selection, r)
        If r Is Nothing Then Exit Sub ' Si aucune intersection, sortir de la macro
        Set r = IIf(r.Count = 1, r.Resize(2), r) ' S'assurer d'avoir au moins 2 cellules
    End If
    
    Application.ScreenUpdating = False ' Désactiver la mise à jour de l'écran pour accélérer
    
    With Sheets("Imprimante")
        .PageSetup.PrintArea = "" ' Effacer la zone d'impression
        .PageSetup.FitToPagesWide = 1 ' 1 page en largeur
        .PageSetup.FitToPagesTall = 1 ' 1 page en hauteur
        
        ' Parcourir chaque cellule constante dans la plage r
        For Each r In r.SpecialCells(xlCellTypeConstants)
            Set P = r.CurrentRegion ' Récupérer la région actuelle de la cellule
            .Cells(6, 2) = r ' Copier la valeur de r dans la cellule (6, 2)
            
            ' Recherche de la cellule contenant "Observation*" dans la colonne 2
            Set foundCell = .Columns(2).Find("Observation*", , xlValues)
            
            ' Si une cellule contenant "Observation*" est trouvée
            If Not foundCell Is Nothing Then
                .Range(.Rows(8), foundCell).Delete ' Effacer la zone de "Observation*" et en dessous
            Else
                ' Aucun "Observation*" trouvé, continuer sans suppression
                MsgBox "Aucune cellule contenant 'Observation*' trouvée dans la colonne 2", vbExclamation
            End If
            
            ' Insérer des lignes en fonction de la taille de P
            .Rows(8).Resize(5 * P.Rows.Count).Insert
            
            ' Boucler à travers les cellules de la colonne 2 dans P
            n = 0
            For Each c In P.Columns(2).Cells
                .Cells(8 + n, 2).Resize(4) = Application.Transpose(c.Resize(, 4))
                n = n + 5 ' Incrémentation de n pour décaler les lignes
            Next c
            
            ' Imprimer ou afficher un aperçu selon la valeur de choix
            If choix Then
                .PrintPreview ' Afficher un aperçu avant impression
            Else
                .PrintOut ' Imprimer directement
            End If
        Next r
    End With
    
    Application.ScreenUpdating = True ' Réactiver la mise à jour de l'écran
End Sub

 

[Caninge]

Donc si je comprends bien la procédure ne crée pas la ligne OBSERVATION avec les petits points.

 

[Caninge]

C'est presque ça. En fait il faut créer une fiche individuel comme dans les fichiers PDF envoyés

 

[kiki29]

Salut, à télécharger puis consulter/adapter à ton contexte : Liste Contributions PDF

 

[job75]

Bonjour Caninge, le forum,

Je reviens avec une méthode classique pour créer les fichiers PDF :

Private Sub CommandButton1_Click() 'bouton PDF
Dim F As Worksheet, i&, n&, j&, k%
Set F = Sheets("PDF")
Application.ScreenUpdating = False
With Range("B3:F" & Cells.SpecialCells(xlCellTypeLastCell).Row)
    For i = 1 To .Rows.Count
        If .Cells(i, 1) <> "" Then
            n = 6
            F.Rows(n & ":" & Rows.Count).ClearContents  'RAZ
            F.Cells(n, 2) = .Cells(i, 1)
            n = n + 2
            j = i
            While .Cells(j, 2) <> ""
                For k = 2 To 5
                    F.Cells(n, 2) = .Cells(j, k): n = n + 1
                Next k
                n = n + 1: j = j + 1
            Wend
            F.Cells(n, 2) = "Observations :"
            For k = 1 To 3: F.Cells(n + k, 2) = String(168, "."): Next k
            F.ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\" & .Cells(i, 1) & ".pdf"
            i = j
        End If
    Next i
End With
End Sub

A+

 

[Caninge]

Bonjour Franc58 Job75,

je viens d'appliquer la macro de Job75.
C'est parfait. Pas besoin d'imprimer en PDF à chaque personne et de nommer le fichier à chaque fois.
Tout se fait automatiquement. Si je savais faire ça...
Merci Beaucoup.

 

[job75]

Dans le fichier de mon post #11 j'ai mis de l'ordre dans les formats de police de la feuille "PDF".

 

[job75]

Bonjour Caninge, le forum,

Par sécurité j'ai ajouté ce code au début de la macro :

'---insère des lignes de séparation vides---
With Range("B3:F" & Cells.SpecialCells(xlCellTypeLastCell).Row)
    For i = .Rows.Count To 2 Step -1
        If .Cells(i, 1) <> "" And Application.CountA(.Rows(i - 1)) Then .Rows(i).Insert xlDown
    Next i
End With

Pour tester entrez un texte en B8 de la 1ère feuille.

A+

 

[Caninge]

Bonjour Job75,
J'ai testé en mettant du texte en B8, Apparemment c'est bon !
Merci