Publipostage filtrer les enregistrements

**MIRTILLEJ77** · 20/10/2018, 21h05

Bonjour à tous,

j'ai un fichier excel avec une colonne "position". je dois faire un publipostage avec Word pour chaque N° de position qui comporte plusieurs lignes; le problème c'est que mon document Word m'est imposé avec un tableau. j'ai réussi à faire une macro qui effectue le publipostage sur Word et qui imprime. mais je dois réécrire la macro pour autant de position que j'ai dans ma base de donnée. Le nombre change tout le temps et varie de 10 à 160. J'aimerai faire une boucle ou pouvoir dire qu'il s'arrête d'imprimer une fois que la ligne est vide.

je vous mets une partie du code, je l'ai copié pour 2 positions :

'1

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
ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=1", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
 
Application.DisplayAlerts = True

'2

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
ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=2", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
 
Application.DisplayAlerts = True

Je vous remercie pour votre aide

Invité · 21/10/2018, 04h17

Envoyé par MIRTILLEJ77

Bonjour,

Le code ci-dessous devrait vous permettre d'identifier les différents numéros de position présents dans votre base. La variable matrice "MatricePositions" étant de portée Public, vous pouvez vous en servir en paramètre dans votre procédure. Faites l'essai sur votre document et regardez le résultat dans la fenêtre exécution (Ctrl_G).

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
 
Option Explicit
 
Public MatricePositions() As Variant
 
Sub InventaireDesPositions()
 
Dim DernierEnregistrement As Integer, IndiceMatrice As Integer, I As Integer
Dim  Id As String
Dim DicoPositions As Object
 
    'Décompte du nombre d'enregistrements dans le publipostage
    With ActiveDocument
 
         .MailMerge.DataSource.ActiveRecord = wdLastRecord
         DernierEnregistrement = .MailMerge.DataSource.ActiveRecord
         .MailMerge.DataSource.ActiveRecord = wdFirstRecord
 
         'Décompte des positions sans doublons
         IndiceMatrice = 0
         Set DicoPositions = CreateObject("Scripting.Dictionary")
 
         For I = 1 To DernierEnregistrement Step 1
             Id = .MailMerge.DataSource.DataFields("POSITION").Value
 
             If Not DicoPositions.Exists(Id) Then
                   DicoPositions.Add Id, Id
                   ReDim Preserve MatricePositions(IndiceMatrice)
                   MatricePositions(IndiceMatrice) = Id
                   IndiceMatrice = IndiceMatrice + 1
             End If
             .MailMerge.DataSource.ActiveRecord = wdNextRecord
         Next I
 
         Set DicoPositions = Nothing
 
 
         For I = LBound(MatricePositions, 1) To UBound(MatricePositions, 1)
             Debug.Print I & " : " & MatricePositions(I)
         Next I
 
    End With
 
End Sub

**MIRTILLEJ77** · 21/10/2018, 10h57

Bonjour Eric et merci pour votre réponse rapide. Je n'arrive pas à intégrer votre macro. Il bloque sur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

ReDim Preserve MatricePositions(IndiceMatrice)

j'ai essayé de vous mettre mes 2 fichiers excel et word mais le docm ne passe pas!

Je vous mets la totalité de mes macros ci-dessous ou j'ai recopié 7 fois pour modifier la "position" :

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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
Private Sub Document_Open()
 
Dim Refs As Object, Ref As Object
On Error Resume Next
With ThisWorkbook
    Set Refs = .VBProject.References
    For Each Ref In Refs
        If Ref.IsBroken Then
            Refs.Remove Ref
        End If
    Next
    'pour ajouter la référence Word dans Excel
    .VBProject.References.AddFromGuid _
        "{00020905-0000-0000-C000-000000000046}", 8, 4
 
 
 
'publipostage
 
Dim nombase As String
nombase = ActiveDocument.Path & "\BASE EMARGE.xlsx"
 
Dim Rep As Integer
 
 
 
ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engin" _
        , SQLStatement:="SELECT * FROM `BASE$`", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
    Rep = MsgBox("voulez vous imprimer ?", vbYesNo + vbQuestion, "mDF XLpages.com")
    If Rep = vbYes Then
        ' ici le traitement si réponse positive
        ' .
        '1
 ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=1", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
 
Application.DisplayAlerts = True
 
'2
 
 ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=2", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
 
Application.DisplayAlerts = True
 
 
'3
 
 ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=3", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
 
Application.DisplayAlerts = True
 
 
'4
 ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=4", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
 
Application.DisplayAlerts = True
 
'5
 ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=5", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
 
Application.DisplayAlerts = True
 
'6
 ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=6", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
 
Application.DisplayAlerts = True
 
'7
 
 ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=7", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
Application.PrintOut FileName:="", Range:=wdPrintAllDocument, Item:= _
        wdPrintDocumentWithMarkup, Copies:=1, Pages:="", PageType:= _
        wdPrintAllPages, Collate:=True, Background:=True, PrintToFile:=False, _
        PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
        PrintZoomPaperHeight:=0
 
Application.DisplayAlerts = True
 
 
    Else
        ' ici le traitement si réponse négative
        '
         ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Eng" _
        , SQLStatement:="SELECT * FROM `BASE$` WHERE `POSITION`=1", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
 
    End If
    End With
 
End Sub
Private Sub Document_Close()
'ferme le document sans publipostage
Dim nombase As String
nombase = ActiveDocument.Path & "\base emarge.xlsx"
Dim Rep As Integer
ActiveDocument.MailMerge.MainDocumentType = wdFormLetters
    ActiveDocument.MailMerge.OpenDataSource Name:= _
        nombase _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:= _
        "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=nombase;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Engin" _
        , SQLStatement:="SELECT * FROM `BASE$`", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
 
Application.DisplayAlerts = False
    ActiveDocument.MailMerge.DataSource.Close
End Sub

merci pour votre aide et bonne journée

Invité · 21/10/2018, 11h04

Envoyé par MIRTILLEJ77

La variable matrice doit être déclarée dans un module Standard. Logiquement toutes vos macros (sauf les événementielles du type Open) devraient être placées un module standard (mais ce n'est pas une obligation).
Pour créer un module standard, clic droit sur ThisDocument (par exemple) et Insérer un module et vous collez mes procédures dedans.

Pour mettre en ligne un fichier contenant des macros (Excel, Word), zipez le.

**MIRTILLEJ77** · 21/10/2018, 19h14

Merci Eric,

mais cela ne donne pas ce que je cherche à obtenir.
c'est une feuille d'émargement et tous les noms ayant le même numéro dans la colonne "position" doivent être sur la même feuille.
j'ai donné le choix à l'ouverture du document aux personnes qui doivent faire le publipostage de cliquer "oui" ou "non.
Lorsqu'ils cliquent sur "non" il choisissent de faire manuellement le changement de N° position dans modifier la liste des destinataire et de l'imprimer.
lorsqu'ils cliquent du "oui" une feuille se génère en position "1" et s'imprime puis une 2ème feuille en position "2" et s'imprime... ce que je n'arrive pas à faire c'est effectivement de trouver le nombre de N° de "position" et que cela se génère et s'imprime jusqu'au dernier N° de position. Sachant que ce nombre change tout le temps.
Je joins le fichier zipper (base excel et fichier word)

Invité · 21/10/2018, 20h34

Envoyé par MIRTILLEJ77

Mon code donne bien les numéros composant la colonne POSITION :

Pièce jointe 421030

**MIRTILLEJ77** · 21/10/2018, 21h34

je n'y arrive pas si je lance la macro seul 1 enregistrement de nom se met sur la feuille. cela devient trop dur pour moi. Je ne connais pas trop VBA. J'avais réussi à faire cette macro en m'aidant sur internet. J’espérai juste l'améliorer pour un gain de temps.
merci encore de votre aide et de m'avoir consacré un peu de temps.

Invité · 22/10/2018, 05h49

Envoyé par MIRTILLEJ77

Testez cette version. Attention à l'extension de la base en relation : ici .xlsm. A l'ouverture, le code recherche les différentes positions du document, les charge dans une boite de dialogue. La sélection d'une position et le clic sur le bouton édite le document

Pièce jointe 421070

Pourquoi n'avez-vous pas utilisé votre fichier Excel pour faire cela ? Un filtre avancé en guise de formulaire aurait été plus facile à faire et n'aurait pas nécessité VBA. Voir le tuto de Philippe TULLIEZ advancedfilter

**MIRTILLEJ77** · 22/10/2018, 20h08

Bonjour Eric,

Un grand merci pour ce travail, c'est super. Il y du coup moins de clic.
Mais n'y a t-il pas moyen d'imprimer toutes les feuilles d'un coup en cliquant sur une boite de dialogue "voulez vous imprimez"= oui non à l'ouverture du document. si on dit "oui" toutes les feuilles s'impriment ; si on dit "non" la boite de dialogue "éditer les listes" s'affiche.

Invité · 22/10/2018, 20h21

Envoyé par MIRTILLEJ77

Il faut passer propriété de la ListBox "ListBoxDesPositions" à fmMultiSelectExtended, vérifier si les enregistrements sont sélectionnés et enclencher une boucle avec le bouton Valider sur ceux-ci.

**MIRTILLEJ77** · 22/10/2018, 21h54

Je suis désolée de revenir vers vous mais j'ai recopié les macros et l'userform que j'ai copié par un clic gauche/glisser dans mon doc initial mais word ne répond pas. Ma base est bien un .xlsm.
mon fichier excel est beaucoup plus lourd que celui sur lequel vous avez travaillé et il y a plusieurs onglets.

Pour le moment je n'ai pas essayé de changer la propriété de la listbox.

Invité · 23/10/2018, 03h58

Envoyé par MIRTILLEJ77

A tester avec la base présente dans le Zip :

Attention à l'emplacement des différentes procédures (ThisDocument, modules standards).

**MIRTILLEJ77** · 23/10/2018, 07h28

vous êtes super. j'ai fait les essais et c'est exactement ce que je cherchais.
J'ai tout copié sur mon doc initial, j'ai fait l'essai avec ma base excel et cela ne fonctionne pas. j'ai écrasé mon fichier avec la base emarge et ca fonctionne, ce n'est donc pas l'extension.
Ma base excel est un fichier de 7000ko avec plusieurs feuilles qui comportent des formules. ma feuille "BASE" a également des formules. Je l'avais allégé pour vous l'envoyer.

Invité · 23/10/2018, 08h50

Envoyé par MIRTILLEJ77

Dupliquez votre onglet BASE dans un nouveau fichier et faites l'essai en modifiant la source dans le publipostage.

Invité · 23/10/2018, 09h46

Envoyé par MIRTILLEJ77

L'userform sur mon fichier a changé, avez vous pensé à l'importer sur votre fichier ?

**MIRTILLEJ77** · 23/10/2018, 21h22

Bonsoir Eric,

j'ai pris vos 2 fichiers. j'ai copié un mes colonnes en dur et sans formules dans le fichier BASE EMARGE avec plus de 103 positions. j'ai ouvert le docm mais rien ne s'ouvre cela tourne en continu.

Invité · 24/10/2018, 01h51

Envoyé par MIRTILLEJ77

Bonjour,

Je peux regarder votre fichier si vous me l'envoyez sur mon adresse mail.

Invité · 24/10/2018, 10h43

Envoyé par MIRTILLEJ77

Effectivement, le chargement de la matrice coince en se servant de l'objet MailMerge.

La numérotation des positions est-elle continue de 1 à N sans trou dans la raquette ?
L'édition partielle en choisissant une ou plusieurs positions est-elle une nécessité ?

**MIRTILLEJ77** · 24/10/2018, 21h01

Non il n'y a pas de trou entre les positions et elle sont classées par ordre numérique.

Non il n'y pas d'obligation à faire pour le choix. On peut le faire manuellement en choisissant la position si on doit réimprimer certaines positions dû à des changements.
Par contre le fait de cliquer sur "oui" et que tout s'imprime est important. En ce moment je fais la manipe jusqu'à 150 fois...

Invité · 25/10/2018, 07h58

Envoyé par MIRTILLEJ77

Pour régler le chargement de la matrice, il faut créer une instance Excel et ouvrir la base avec ce code.

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
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
 
 
Sub M100_InventaireDesPositionsExcel(ByVal NomDeLaBaseAOuvrir As String)
 
Dim DernierEnregistrement As Integer, IndiceMatrice As Integer, I As Integer
Dim Id As String
Dim ShBase As Excel.Worksheet
Dim BaseLigneDeTitre As Long, BaseDerniereLigne As Long, BaseColPosition As Long
Dim AirePosition As Range, CellulePosition As Range
Dim DicoPositions As Object
 
Dim xlApp As Object
Dim FichierExcel As Object
 
       On Error GoTo Fin
 
 
 
       Set xlApp = CreateObject("Excel.Application")
      ' Repertoire = ActiveDocument.Path  ' A adapter
      ' FichierAOuvrir = NomDeLaBaseAOuvrir 'Repertoire & "\" & "fichier_liste.xlsm"
       With xlApp
 
           .Visible = True
          Set FichierExcel = .Workbooks.Open(FileName:=NomDeLaBaseAOuvrir)
          With FichierExcel
 
               Set ShBase = .Sheets("BASE")
 
               'Décompte du nombre d'enregistrements dans le publipostage
               With ShBase
 
                        Application.ScreenUpdating = False
                        BaseLigneDeTitre = 1
                        BaseColPosition = M100_ColonneFeuille(ShBase, BaseLigneDeTitre, "POSITION")
                        If BaseColPosition = 0 Then
                           MsgBox "Aucune colonne POSITION trouvée !", vbCritical
                           GoTo Fin
                        End If
                        BaseDerniereLigne = .Cells(.Rows.Count, BaseColPosition).End(xlUp).Row
                        'Décompte des positions sans doublons
                        IndiceMatrice = 0
                        Set DicoPositions = CreateObject("Scripting.Dictionary")
 
                        For I = BaseLigneDeTitre + 1 To BaseDerniereLigne
                            Id = .Cells(I, BaseColPosition)
 
                            If Not DicoPositions.Exists(Id) Then
                                  DicoPositions.Add Id, Id
                                  ReDim Preserve MatricePositions(1, IndiceMatrice)
                                  MatricePositions(0, IndiceMatrice) = Id
                                  IndiceMatrice = IndiceMatrice + 1
                            End If
                        Next I
                        Set DicoPositions = Nothing
 
 
                        For I = LBound(MatricePositions, 2) To UBound(MatricePositions, 2)
 
                            'Debug.Print I & " : " & MatricePositions(0, I)
                            With Usf_M000_CouplerLaBase.ListBoxDesPositions
                                 .AddItem MatricePositions(0, I)
                            End With
                        Next I
 
                End With
 
                .Close savechanges:=False
 
 
          End With
          Set FichierExcel = Nothing
      End With
 
      xlApp.Quit
      Set xlApp = Nothing
 
 
    GoTo Fin
 
 
Fin:
 
   Application.ScreenUpdating = True
 
   Set ShBase = Nothing
 
 
End Sub
 
 
Function M100_ColonneFeuille(ByVal FeuilleTitre As Excel.Worksheet, ByVal LigneTitre As Long, ByVal TitreRecherche As String) As Long
 
Dim NbColonnes As Long
Dim Cellule As Excel.Range
Dim Aire As Excel.Range
 
    With FeuilleTitre
 
         M100_ColonneFeuille = 0
         NbColonnes = .Cells(LigneTitre, .Columns.Count).End(xlToLeft).Column
         Set Aire = .Range(.Cells(LigneTitre, 1), .Cells(LigneTitre, NbColonnes))
 
         For Each Cellule In Aire
             Select Case Mid(Cellule.Value, 1, Len(TitreRecherche))
                    Case TitreRecherche
                         M100_ColonneFeuille = Cellule.Column
                         Exit For
             End Select
         Next
 
         If M100_ColonneFeuille = 0 Then DetectionColonnes = DetectionColonnes & Chr(10) & TitreRecherche
 
         Set Aire = Nothing
 
    End With
 
End Function

Publipostage filtrer les enregistrements

VBA Word

Discussions similaires

Partager

Partager