Problème dans l’automation d’un publipostage

**apt** · 28/10/2012, 22h47

Bonsoir à tous,

Dans les colonnes d'une feuille Excel, j'ai les étiquettes suivantes :

1- Colonne A : Matricule

2- Colonne B : Nom

3- Colonne C :Fonction

4- Colonne D : Service

5- Colonne E : Destination

6- Colonne F : Motif

7- Colone G : Etiquette

8- Colonne I : Réf

La feuille source :

Matricule Nom Fonction Service Destination Motif Etiquette Réf

650014747 Dupont Technicien Bâtiment D2 M1 x 6

680004578 Laurent Attaché administratif Compatibilité

750017915 Lajoie Technicien Informatique D1 M3 x

608945128 Durand Attaché administratif Compatibilité

Le fichier doc de fusion se presente ainsi :

Réf : … «Réf»…. du …«Date» ….

Matricule :……«Matricule»……………..
Nom :……«Nom»..…………………..
Fonction :……«Fonction»……………..
Service :……«Service»……………….
Destination :….. «Destination»…………
Motif :……«Motif»………………….

Je m'en sers du code suivant pour faire du publipostage.

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
50
51
52
53
54
55
56
'Option Explicit
 
Sub Publipostage()
    Application.ScreenUpdating = False
    Chemin = ThisWorkbook.Path
    With Sheets("feuil1")
        .Activate
        NbreX = Application.CountIf(.Range(.[G2], .[G65536]), "x")
        If NbreX = 0 Then
            MsgBox "Il n'y a pas d'étiquette à extraire.", vbInformation + vbOKOnly
            .Range("A1").Select
            Exit Sub
        End If
    End With
 
    'Sheets(Array("feuil1", "Listes")).Copy
    Sheets("feuil1").Copy
    ActiveWorkbook.Close savechanges:=True, Filename:=Chemin & "\Temp.xls"
    ChDir ThisWorkbook.Path
    FileMailing = Application.GetOpenFilename("Fichiers Word (*.doc), *.doc", , "Ouvrir le document Word pour le mailing d'étiquettes ...")
    If FileMailing = False Then End
    'Si c'est OK on incrémente la référence
    [J2] = [J2] + 1
    ' Ouverture de Word
    Dim AppWord As Word.Application
    Set AppWord = New Word.Application
    AppWord.Visible = True 'False    'True
    Set DocWord = AppWord.Documents.Open(FileMailing)
    NomBase = Chemin & "\Temp.xls"
    With DocWord.MailMerge
        .OpenDataSource Name:=NomBase, _
                        Connection:="Driver={Microsoft Excel Driver (*.xls)};" & "DBQ=" & _
                                    NomBase & "; ReadOnly=True;", SQLStatement:="SELECT * FROM [feuil1$] WHERE [ETIQUETTE] like 'x' OR [ETIQUETTE] like 'X'"
        'Spécifie la fusion vers un nouveau document (wdSendToPrinter= Vers l'imprimante)
        .Destination = wdSendToNewDocument
        '.SuppressBlankLines = True 'Il ne peut pas y voir de ligne blanche car on demande celle qui ont des croix
        'Prend en compte l'ensemble des enregistrements
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        'Exécute l'opération de publipostage
        .Execute Pause:=False
    End With
    ' Activation du doucment principal de Publipostage et fermeture
    DocWord.Activate
    DocWord.Close savechanges:=False
    ' Affichage l'application Word
    AppWord.Visible = True
    Set DocWord = Nothing
    Set AppWord = Nothing
    ' Activation de l'onglet
    ' Effacement du fichier temporaire crée spécialement pour la fusion
    Kill Chemin & "\temp.xls"
    Application.ScreenUpdating = True
End Sub

Seulement j'ai deux problèmes :

1) En choisissant dans la feuille source Excel, deux lignes marquées par une croix "x", l'extraction vers le document Word de fusion, ne s'exécute que pour la première ligne marquée. La deuxième ligne de données est ignorée.

2) En choisissant de réaliser le publipostage ligne par ligne, la date du jour est inscrite une seule fois dans le premier document, et en répétant la tache une deuxième fois, la date n'apparait plus.

Une solution ?

Merci d'avance.