Problème d'exportation en VBA de xls à docx et pdf

Résolu
IvyJu Messages postés 19 Date d'inscription lundi 20 janvier 2020 Statut Membre Dernière intervention 14 septembre 2024 - 13 sept. 2024 à 22:38
IvyJu Messages postés 19 Date d'inscription lundi 20 janvier 2020 Statut Membre Dernière intervention 14 septembre 2024 - 14 sept. 2024 à 08:31

Bonjour,

J'ai un problème lorsque je fais mon exportation. Je voudrais que ça n'exporte que ce que j'ai qui est affiché dans mon formulaire ouvert qui s'appelle lbm_frm_ajouter. Mais ça me fait un document par ligne. Je ne sais pas comment m'en sortir. Je vous mets le code de mon bouton exporter ci-dessous:

Private Sub ExporterVersWordEtPDF_Click()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim ws As Worksheet
    Dim rng As Range
    Dim cheminModele As String
    Dim cheminExportWord As String
    Dim cheminExportPDF As String
    Dim nomFichier As String
    
    ' Définir les chemins
    cheminModele = ThisWorkbook.Path & "\ldm.docx"
    cheminExportWord = ThisWorkbook.Path & "\ldm\word\"
    cheminExportPDF = ThisWorkbook.Path & "\ldm\pdf\"
    
    ' S'assurer que les répertoires d'exportation existent
    If Dir(cheminExportWord, vbDirectory) = "" Then
        MkDir cheminExportWord
    End If
    If Dir(cheminExportPDF, vbDirectory) = "" Then
        MkDir cheminExportPDF
    End If
    
    ' Créer une nouvelle instance de Word
    Set wdApp = CreateObject("Word.Application")
    
    ' Ouvrir le modèle Word
    Set wdDoc = wdApp.Documents.Open(cheminModele)
    
    ' Définir la feuille de calcul
    Set ws = ThisWorkbook.Sheets("ldm_donnees") ' Remplacez "Feuille1" par le nom de votre feuille
    
    ' Parcourir les lignes et exporter les données
    For Each rng In ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row) ' Ajustez la plage si nécessaire
        ' Remplacer les espaces réservés par les données
        With wdDoc.Content.Find
            .Text = "<nom_entreprise>"
            .Replacement.Text = rng.Offset(0, 0).Value ' nom_entreprise
            .Execute Replace:=2
            
            .Text = "<type_entreprise>"
            .Replacement.Text = rng.Offset(0, 1).Value ' type_entreprise
            .Execute Replace:=2
            
            .Text = "<num_rue_entreprise>"
            .Replacement.Text = rng.Offset(0, 2).Value ' num_rue_entreprise
            .Execute Replace:=2
            
            .Text = "<rue_entreprise>"
            .Replacement.Text = rng.Offset(0, 3).Value ' rue_entreprise
            .Execute Replace:=2
            
            .Text = "<npa_entreprise>"
            .Replacement.Text = rng.Offset(0, 4).Value ' npa_entreprise
            .Execute Replace:=2
            
            .Text = "<ville_entreprise>"
            .Replacement.Text = rng.Offset(0, 5).Value ' ville_entreprise
            .Execute Replace:=2
            
            .Text = "<siret>"
            .Replacement.Text = rng.Offset(0, 6).Value ' siret
            .Execute Replace:=2
            
            .Text = "<immat_rcs>"
            .Replacement.Text = rng.Offset(0, 7).Value ' immat_rcs
            .Execute Replace:=2
            
            .Text = "<capital>"
            .Replacement.Text = rng.Offset(0, 8).Value ' capital
            .Execute Replace:=2
            
            .Text = "<titre_representant>"
            .Replacement.Text = rng.Offset(0, 9).Value ' titre_representant
            .Execute Replace:=2
            
            .Text = "<nom_representant>"
            .Replacement.Text = rng.Offset(0, 10).Value ' nom_representant
            .Execute Replace:=2
            
            .Text = "<prenom_representant>"
            .Replacement.Text = rng.Offset(0, 11).Value ' prenom_representant
            .Execute Replace:=2
            
            .Text = "<activite>"
            .Replacement.Text = rng.Offset(0, 12).Value ' activite
            .Execute Replace:=2
            
            .Text = "<debut>"
            .Replacement.Text = rng.Offset(0, 13).Value ' debut
            .Execute Replace:=2
            
            .Text = "<fin>"
            .Replacement.Text = rng.Offset(0, 14).Value ' fin
            .Execute Replace:=2
            
            .Text = "<effectif>"
            .Replacement.Text = rng.Offset(0, 15).Value ' effectif
            .Execute Replace:=2
            
            .Text = "<forfait_ht>"
            .Replacement.Text = rng.Offset(0, 16).Value ' forfait_ht
            .Execute Replace:=2
            
            .Text = "<forfait_ttc>"
            .Replacement.Text = rng.Offset(0, 17).Value ' forfait_ttc
            .Execute Replace:=2
            
            .Text = "<bulletin_forfait>"
            .Replacement.Text = rng.Offset(0, 18).Value ' bulletin_forfait
            .Execute Replace:=2
            
            .Text = "<max_ou_pas>"
            .Replacement.Text = rng.Offset(0, 19).Value ' max_ou_pas
            .Execute Replace:=2
            
            .Text = "<acompte_ht>"
            .Replacement.Text = rng.Offset(0, 20).Value ' acompte_ht
            .Execute Replace:=2
            
            .Text = "<acompte_ttc>"
            .Replacement.Text = rng.Offset(0, 21).Value ' acompte_ttc
            .Execute Replace:=2
            
            .Text = "<bulletin_acompte>"
            .Replacement.Text = rng.Offset(0, 22).Value ' bulletin_acompte
            .Execute Replace:=2
            
            .Text = "<x>"
            .Replacement.Text = rng.Offset(0, 23).Value ' x
            .Execute Replace:=2
            
            .Text = "<y>"
            .Replacement.Text = rng.Offset(0, 24).Value ' y
            .Execute Replace:=2
            
            .Text = "<tarif_bulletin>"
            .Replacement.Text = rng.Offset(0, 25).Value ' tarif_bulletin
            .Execute Replace:=2
            
            .Text = "<facture_ht>"
            .Replacement.Text = rng.Offset(0, 26).Value ' facture_ht
            .Execute Replace:=2
            
            .Text = "<facture_ttc>"
            .Replacement.Text = rng.Offset(0, 27).Value ' facture_ttc
            .Execute Replace:=2
            
            .Text = "<debut_mission>"
            .Replacement.Text = rng.Offset(0, 28).Value ' debut_mission
            .Execute Replace:=2
            
            .Text = "<lieu>"
            .Replacement.Text = rng.Offset(0, 29).Value ' lieu
            .Execute Replace:=2
            
            .Text = "<date_contrat>"
            .Replacement.Text = rng.Offset(0, 30).Value ' date_contrat
            .Execute Replace:=2
       End With
        
        ' Définir le nom du fichier
        nomFichier = "ldm_" & rng.Offset(0, 0).Value & "_" & rng.Offset(0, 1).Value
        
        ' Enregistrer le document Word
        wdDoc.SaveAs2 cheminExportWord & nomFichier & ".docx"
        
        ' Enregistrer le document en PDF
        wdDoc.ExportAsFixedFormat OutputFileName:=cheminExportPDF & nomFichier & ".pdf", ExportFormat:=17
        
        ' Fermer le document Word sans enregistrer les modifications (car le fichier a déjà été enregistré)
        wdDoc.Close SaveChanges:=False
        
        ' Ouvrir le PDF enregistré
        Shell "explorer.exe " & cheminExportPDF & nomFichier & ".pdf", vbNormalFocus
        
        ' Ouvrir un nouveau document basé sur le modèle pour la prochaine itération
        Set wdDoc = wdApp.Documents.Open(cheminModele)
    Next rng
    
    ' Fermer l'application Word
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    
    MsgBox "Exportation terminée avec succès !"
End Sub

Merci infiniment pour votre aide :)

A voir également:

2 réponses

IvyJu Messages postés 19 Date d'inscription lundi 20 janvier 2020 Statut Membre Dernière intervention 14 septembre 2024 1
14 sept. 2024 à 08:31

Merci c'est super ça fonctionne très bien ☺️ 

1
Bruno83200_6929 Messages postés 185 Date d'inscription jeudi 18 juin 2020 Statut Membre Dernière intervention 17 septembre 2024 31
14 sept. 2024 à 08:27

Bonjour,

Actuellement, vous parcourez chaque ligne avec une boucle For Each rng, ce qui crée un fichier pour chaque ligne.

Extraire les données du formulaire au lieu de parcourir les lignes de la feuille de calcul. Passer ces données directement à Word sans boucle.

Vous pouvez accéder aux contrôles du formulaire (TextBox, ComboBox, etc.) pour obtenir les données que vous souhaitez exporter.

Vous n'avez besoin que d'une seule exportation basée sur les données du formulaire, donc vous pouvez enlever la boucle For Each.

Private Sub ExporterVersWordEtPDF_Click()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim cheminModele As String
    Dim cheminExportWord As String
    Dim cheminExportPDF As String
    Dim nomFichier As String

    ' Définir les chemins
    cheminModele = ThisWorkbook.Path & "\ldm.docx"
    cheminExportWord = ThisWorkbook.Path & "\ldm\word\"
    cheminExportPDF = ThisWorkbook.Path & "\ldm\pdf\"
    
    ' S'assurer que les répertoires d'exportation existent
    If Dir(cheminExportWord, vbDirectory) = "" Then
        MkDir cheminExportWord
    End If
    If Dir(cheminExportPDF, vbDirectory) = "" Then
        MkDir cheminExportPDF
    End If
    
    ' Créer une nouvelle instance de Word
    Set wdApp = CreateObject("Word.Application")
    
    ' Ouvrir le modèle Word
    Set wdDoc = wdApp.Documents.Open(cheminModele)

    ' Remplacer les espaces réservés par les données du formulaire lbm_frm_ajouter
    With wdDoc.Content.Find
        .Text = "<nom_entreprise>"
        .Replacement.Text = lbm_frm_ajouter.txtNomEntreprise.Value
        .Execute Replace:=2
        
        .Text = "<type_entreprise>"
        .Replacement.Text = lbm_frm_ajouter.txtTypeEntreprise.Value
        .Execute Replace:=2
        
        .Text = "<num_rue_entreprise>"
        .Replacement.Text = lbm_frm_ajouter.txtNumRueEntreprise.Value
        .Execute Replace:=2
        
        .Text = "<rue_entreprise>"
        .Replacement.Text = lbm_frm_ajouter.txtRueEntreprise.Value
        .Execute Replace:=2
        
        .Text = "<npa_entreprise>"
        .Replacement.Text = lbm_frm_ajouter.txtNPAEntreprise.Value
        .Execute Replace:=2
        
        .Text = "<ville_entreprise>"
        .Replacement.Text = lbm_frm_ajouter.txtVilleEntreprise.Value
        .Execute Replace:=2
        
        .Text = "<siret>"
        .Replacement.Text = lbm_frm_ajouter.txtSiret.Value
        .Execute Replace:=2
        
        .Text = "<immat_rcs>"
        .Replacement.Text = lbm_frm_ajouter.txtImmatRCS.Value
        .Execute Replace:=2
        
        .Text = "<capital>"
        .Replacement.Text = lbm_frm_ajouter.txtCapital.Value
        .Execute Replace:=2
        
        .Text = "<titre_representant>"
        .Replacement.Text = lbm_frm_ajouter.txtTitreRepresentant.Value
        .Execute Replace:=2
        
        .Text = "<nom_representant>"
        .Replacement.Text = lbm_frm_ajouter.txtNomRepresentant.Value
        .Execute Replace:=2
        
        .Text = "<prenom_representant>"
        .Replacement.Text = lbm_frm_ajouter.txtPrenomRepresentant.Value
        .Execute Replace:=2
        
        .Text = "<activite>"
        .Replacement.Text = lbm_frm_ajouter.txtActivite.Value
        .Execute Replace:=2
        
        .Text = "<debut>"
        .Replacement.Text = lbm_frm_ajouter.txtDebut.Value
        .Execute Replace:=2
        
        .Text = "<fin>"
        .Replacement.Text = lbm_frm_ajouter.txtFin.Value
        .Execute Replace:=2
        
        .Text = "<effectif>"
        .Replacement.Text = lbm_frm_ajouter.txtEffectif.Value
        .Execute Replace:=2
        
        .Text = "<forfait_ht>"
        .Replacement.Text = lbm_frm_ajouter.txtForfaitHT.Value
        .Execute Replace:=2
        
        .Text = "<forfait_ttc>"
        .Replacement.Text = lbm_frm_ajouter.txtForfaitTTC.Value
        .Execute Replace:=2
        
        .Text = "<bulletin_forfait>"
        .Replacement.Text = lbm_frm_ajouter.txtBulletinForfait.Value
        .Execute Replace:=2
        
        .Text = "<max_ou_pas>"
        .Replacement.Text = lbm_frm_ajouter.txtMaxOuPas.Value
        .Execute Replace:=2
        
        .Text = "<acompte_ht>"
        .Replacement.Text = lbm_frm_ajouter.txtAcompteHT.Value
        .Execute Replace:=2
        
        .Text = "<acompte_ttc>"
        .Replacement.Text = lbm_frm_ajouter.txtAcompteTTC.Value
        .Execute Replace:=2
        
        .Text = "<bulletin_acompte>"
        .Replacement.Text = lbm_frm_ajouter.txtBulletinAcompte.Value
        .Execute Replace:=2
        
        .Text = "<x>"
        .Replacement.Text = lbm_frm_ajouter.txtX.Value
        .Execute Replace:=2
        
        .Text = "<y>"
        .Replacement.Text = lbm_frm_ajouter.txtY.Value
        .Execute Replace:=2
        
        .Text = "<tarif_bulletin>"
        .Replacement.Text = lbm_frm_ajouter.txtTarifBulletin.Value
        .Execute Replace:=2
        
        .Text = "<facture_ht>"
        .Replacement.Text = lbm_frm_ajouter.txtFactureHT.Value
        .Execute Replace:=2
        
        .Text = "<facture_ttc>"
        .Replacement.Text = lbm_frm_ajouter.txtFactureTTC.Value
        .Execute Replace:=2
        
        .Text = "<debut_mission>"
        .Replacement.Text = lbm_frm_ajouter.txtDebutMission.Value
        .Execute Replace:=2
        
        .Text = "<lieu>"
        .Replacement.Text = lbm_frm_ajouter.txtLieu.Value
        .Execute Replace:=2
        
        .Text = "<date_contrat>"
        .Replacement.Text = lbm_frm_ajouter.txtDateContrat.Value
        .Execute Replace:=2
    End With

    ' Définir le nom du fichier basé sur les données du formulaire
    nomFichier = "ldm_" & lbm_frm_ajouter.txtNomEntreprise.Value & "_" & lbm_frm_ajouter.txtTypeEntreprise.Value

    ' Enregistrer le document Word
    wdDoc.SaveAs2 cheminExportWord & nomFichier & ".docx"
    
    ' Enregistrer le document en PDF
    wdDoc.ExportAsFixedFormat OutputFileName:=cheminExportPDF & nomFichier & ".pdf", ExportFormat:=17
    
    ' Fermer le document Word sans enregistrer les modifications
    wdDoc.Close SaveChanges:=False
    
    ' Ouvrir le PDF enregistré
    Shell "explorer.exe " & cheminExportPDF & nomFichier & ".pdf", vbNormalFocus
    
    ' Fermer l'application Word
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    
    MsgBox "Exportation terminée avec succès !"
End Sub

Cela devrait limiter l'exportation à ce qui est affiché dans le formulaire lbm_frm_ajouter.


0