Publipostage Word à partir d'Excel

olggapt

XLDnaute Junior
Bonjour

J'ai construit une macro dans Excel qui automatise le publipostage dans Word :
La base de données est System.xls
Le doc Word est Navette.doc

Code:
Sub Publipostage()
 
Dim WordApp As Object
Dim WordDoc As Object
 
    Set WordApp = CreateObject("word.application")
    WordApp.Visible = True
    
    Set WordDoc = WordApp.Documents.Open("C:\Documents and Settings\Ptriquet\Bureau\BaseFinancière\Navette.doc")
    WordDoc.MailMerge.OpenDataSource Name:="C:\Documents and Settings\Ptriquet\Bureau\BaseFinancière\System.xls"

    WordDoc.MailMerge.Execute
 

End Sub

Hélas ! A l'ouverture d'Excel (System.xls) Word me demande de sélectionner un tableau !
Comment éviter cette fenêtre pour terminer la fusion ?
NB. System.xls est composé de 2 feuilles. Dans l'une d'elle se trouve les données de fusion.

Merci à vous !
 

escouger

XLDnaute Occasionnel
Re : Publipostage Word à partir d'Excel

Bonjour à nouveau,

J'ai préparé une version édulcorée de mon tableau pour pouvoir l'envoyer en pièces jointes.
Tu trouveras donc un fichier excel contenant les macros et le fichier Word qui sert de modèle aux lettres à publier.
Normalement 3 lettres devraient être crées (Test1 à Test3 dans le premier champ variable).
Pour le moment l'éclatement ne fonctionne pas, et j'ai aussi remarqué que le fichier généré sans demander l'éclatement
ne produit que le première lettre (Test1). Il y a donc 2 soucis différents:
1) Pourquoi sans éclatement le fichier résultat ne contient-t-il pas 3 lettres?
2) Pourqoi l'éclatement ne se fait pas quand j'active la macro .Call SaveRecAsFiles?

Merci encore de bien vouloir m'aider à comprendre ce code.
 

MichD

XLDnaute Impliqué
Re : Publipostage Word à partir d'Excel

Voici un exemple complet incluant la lettre servant au publipostage et le fichier Excel.

Tu décompresses le fichier .zip et tu laisses les 2 fichiers dans le même répertoire.

Ouvre le fichier Excel et exécute la macro "Publipostage".

Dans le module1, j'ai ajouté quelques explications importantes que tu devrais lire...
 

Pièces jointes

  • Publipostage.zip
    31.2 KB · Affichages: 110
  • Publipostage.zip
    31.2 KB · Affichages: 98
  • Publipostage.zip
    31.2 KB · Affichages: 114
Dernière édition:

MichD

XLDnaute Impliqué
Re : Publipostage Word à partir d'Excel

Une version améliorée des fichiers précédents. Explications dans le module1


Voici le contenu du module1

VB:
'La référence Microsoft Word xx Objects Library" a été ajoutée
'à la liste des références.

'Une autre référence a été ajoutée :
'Microsoft ActiveX Data Object 2.8 Library

'Le document (lettre) servant au publipostage doit débuté obligatoirement
'par ce qu'on appelle en anglais : Microsoft Word’s built-in heading. Si
'tu affiches les symboles non imprimables, tu as un petit carré au tout début
'de ton document afin de pouvoir scinder chacune des sections du document
'contenant le Publipostage en document unique.

'Pour ce faire, le menu "Références" du ruban et dans la section "Table des matières",
'clique sur la petite flèche à l'extrémité de la commande "Ajouter le texte" et tu cliques
'dans la fenêtre ouvrante "Niveau 1"

'La ou les conditions "WHERE" dans les 2 requêtes, l'une dans la procédure "Publipostage" et l'autre
'dans la fonction "Prénom_Nom" doivent être identiques...

'Dans l'exemple,
'Requete = "SELECT * FROM [" & Feuille & "$] WHERE Prénom is not null;"
'On ne tient pas compte des enregistrements où le Prénom est absent.

Dim Feuille As String
Dim Source As String
'---------------------------------------------------------------------------
Sub Publipostage()

Dim Wd As Word.Application
Dim WdDoc As Word.Document, Doc As Word.Document
Dim Chemin As String, Fichier As String
Dim Chemin_Fichier As String

Application.ScreenUpdating = False

'l'Exemple suppose que le fichier Excel et la lettre Word
'sont dans le même répertoire. À adapter au besoin

' récupère le chemin des fichiers de la feuille "saisie"
' cellule "Chemin"
Chemin = ThisWorkbook.Path & "\"

'Nom de la lettre DOC pour le publipostage
Fichier = "Test.docm"

'Chemin & lettre Word pour publipostage
Chemin_Fichier = Chemin & Fichier

'Chemin est nom du fichier Excel où est la base de données
'pour le publipostage
Source = ThisWorkbook.FullName

'Nom de la feuille où se retrouvent les données du classeur.
Feuille = ThisWorkbook.Worksheets("Data").Name

'Démarrer Word en ouvrant la lettre type
Set Wd = CreateObject("Word.Application")
Wd.Visible = False
Set WdDoc = Wd.Documents.Open(Chemin_Fichier)

With WdDoc
      'Créé la liaison à la base de données afin de pouvoir
     ' déplacer facilement les fichiers.
     ' Source contient le chemin d'accès au fichier
     .MailMerge.OpenDataSource _
          Name:=Source, _
          LinkToSource:=True, _
          Format:=wdOpenFormatAuto, _
          SqlStatement:="SELECT * FROM [" & Feuille & "$] WHERE Prénom is not null;"

      ' Lancer la fusion du 1er et seul enreg vers un nouveau doc
     With .MailMerge
        '.MainDocumentType = wdDirectory
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
          With .DataSource
              .FirstRecord = 1
              .LastRecord = -5
          End With
          .Execute Pause:=False
          Call SaveRecsAsFiles(Wd)
      End With

        ' Ferme le doc ayant servi de modèle sans l'enregistrer
        For Each Doc In .Parent.Documents
            Doc.Close (False)
        Next
        Wd.Quit
End With
' Libère la mémoire
Set Doc = Nothing: Set WdDoc = Nothing: Set Wd = Nothing

'Ouvrir le répertoire où se retrouvent tous les fichiers (Observer le résultat)
Shell "C:\Windows\EXPLORER.EXE /e,/root," & ThisWorkbook.Path, vbNormalFocus
End Sub
'---------------------------------------------------------------------------
Sub SaveRecsAsFiles(Wd As Word.Application)
Dim T()
' Convert all sections to Subdocs
AllSectionsToSubDoc Wd.ActiveDocument
'Save each Subdoc as a separate file
SaveAllSubDocs Wd.ActiveDocument, T()
 End Sub
'---------------------------------------------------------------------------
Sub AllSectionsToSubDoc(ByRef Doc As Word.Document)
Dim secCounter As Long
Dim NrSecs As Long

NrSecs = Doc.Sections.Count - 1
'Start from the end because creating
'Subdocs inserts additional sections
Doc.ActiveWindow.View.Type = wdMasterView

For secCounter = NrSecs To 1 Step -1
    With Doc
        Doc.Subdocuments.AddFromRange Doc.Sections(secCounter).Range
    End With
Next secCounter
 End Sub
'---------------------------------------------------------------------------
Sub SaveAllSubDocs(ByRef Doc As Word.Document, T())
Dim subdoc As Word.Subdocument
Dim NewDoc As Word.Document
Dim DocCounter As Long
Dim NomDocument As String

'Extrait le prénom et le nom de chaque enregistrement de la base de données
'de la feuille de calcul.
Prénom_Nom T()

DocCounter = 1
'Must be in MasterView to work with
'Subdocs as separate files
Doc.ActiveWindow.View = wdMasterView
For Each subdoc In Doc.Subdocuments
    'Extrait le nom du prénom et du nom pour l'attribuer au nom du fichier.
    NomDocument = T(0, DocCounter - 1) & " " & T(1, DocCounter - 1)
    Set NewDoc = subdoc.Open
    'Remove NextPage section breaks
    'originating from mailmerge
    RemoveAllSectionBreaks NewDoc
    With NewDoc
        .SaveAs2 Filename:=ThisWorkbook.Path & "\" & NomDocument & _
            ".docx", FileFormat:=wdFormatDocumentDefault
        .Close False
    End With
    DocCounter = DocCounter + 1
    
Next subdoc
End Sub
'---------------------------------------------------------------------------
Sub RemoveAllSectionBreaks(Doc As Word.Document)
With Doc.Range.Find
.ClearFormatting
.Text = "^b"
With .Replacement
    .ClearFormatting
    .Text = ""
End With
    .Execute Replace:=wdReplaceAll
End With
End Sub
'--------------------------------------------------------------------------- 
Function Prénom_Nom(T())

'nécessite une référence à la librairie
'Microsoft ActiveX Data Object 2.8 Library
Dim Rst As ADODB.Recordset
Dim StConnect As String
Dim Requete As String

If Val(Application.Version) < 12 Then
    ' Crée la chaîne de connexion
    StConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Source & ";" & _
        "Extended Properties=Excel 8.0;"
Else
    StConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & Source & ";" & _
        "Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
    ' La requête est basée sur le nom de la feuille. Ce nom
    ' doit se terminer par un $ et doit être entouré de crochets droits.
    'Évidemment il faut adapter le nom des champs au besoin...
    Requete = "SELECT Prénom, Nom FROM [" & Feuille & "$] WHERE Prénom is not null;"

    Set Rst = New ADODB.Recordset
    Rst.Open Requete, StConnect, adOpenStatic, _
        adLockReadOnly, adCmdText

    If Rst.RecordCount > 0 Then
        T = Rst.GetRows
    End If
End Function
'---------------------------------------------------------------------------
 

Pièces jointes

  • Publipostage.zip
    36 KB · Affichages: 80
  • Publipostage.zip
    36 KB · Affichages: 95
  • Publipostage.zip
    36 KB · Affichages: 106
Dernière édition:

escouger

XLDnaute Occasionnel
Re : Publipostage Word à partir d'Excel

Bonjour,

Merci beaucoup pour cette aide précieuse et tout le temps que vous y avez consacré.
C'est maintenant parfait à 100% pour ce que je voulais faire et en plus...j'ai tout compris!
J'ai adapté ce code à mon environnement et le résultat est impeccable.
Merci encore
 

Discussions similaires