VBA Copier donnée si date = et autre condition

**Harreauv** · 28/01/2013, 19h50

Bonjour,

Je suis un newbie sur VB, et je m'efforce de faire une macro pour mon asso.
Je vous explique mon problème:

J'ai des feuilles de données correspondant à des dons pour des missions de mon asso.

J'aimerai pouvoir sélectionner les données (sur deux feuilles différentes) selon la date ET la mission pour les copier dans deux nouvelles feuilles pour, à terme, en faire un publipostage de remerciement.

Je suis arrivé à sélectionner les données par mission.
En voulant allonger le schéma avec les dates, plus rien ne se produit.

J'apprends VB tout seul. Cette macro résulte d'adaptation de macro vues sur ce forum ou autres donc si vous avez des conseils, modifications... ce sera avec grand plaisir

Merci!

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
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
Sub Choix_date()
 
On Error Resume Next
 
' sélection des données en fonction de la date
 
Dim A As String
Dim B As String
Dim K As Worksheet
Dim L As Worksheet
Dim M As Range
Dim FirstFound2 As String
Dim Plg1 As Range
Dim Plg2 As Range
Dim EcartNeg As Integer
 
 
A = Application.InputBox("Date d'enregistrement?", "Choix Date", Type:=Date) 'quelle date choisir
 
 
If A = vbNullString Then
    Exit Sub
    Else
Set K = Worksheets("Dons Chèques")                          ' On travaille sur l'onglet chèques
Set Plg1 = K.Range(K.Cells(1, 1), K.Cells(1000, 1))
 
With Plg1
 
    Set M = .Find(A, LookIn:=xlValues, LookAt:=xlPart)
        If Not (M Is Nothing) Then
            FirstFound2 = M.Address
            Do
                M.Offset(0, 15).Value = "OK !"
                Set M = .FindNext(M)
            Loop While M.Address <> FirstFound2
 
        Else
            MsgBox "Cette date n'est pas répertorié", vbOKOnly, "Dons Chèques"
 
        End If
 
End With
 
    Dim shtoto As Worksheet                             'création de la feuille temporaire pour les données sélectionnées selon la date
 
    Set shname = Sheets.Add(After:=Sheets(Sheets.Count))
 
Application.DisplayAlerts = False
 
For Each X In Sheets
If X.Name = A Then X.Delete
Next
Application.DisplayAlerts = True
 
    shname.Name = "Date_" + A + "_chèques"
Set L = Worksheets("Dons Virements")                'idem sur la deuxième feuille
Set Plg2 = L.Range(L.Cells(1, 1), L.Cells(1000, 1))
With Plg2
 
    Set M = .Find(A, LookIn:=xlValues, LookAt:=xlPart)
        If Not (M Is Nothing) Then
            FirstFound2 = M.Address
            Do
                M.Offset(0, 15).Value = "OK !"
                Set M = .FindNext(M)
            Loop While M.Address <> FirstFound2
 
        Else
            MsgBox "Cette date n'est pas répertoriée", vbOKOnly, "Dons Virements"
 
 
        End If
        End With
 
Dim shtoto5 As Worksheet
 
    Set shname = Sheets.Add(After:=Sheets(Sheets.Count))
 
Application.DisplayAlerts = False
 
For Each X In Sheets
If X.Name = A Then X.Delete
Next
Application.DisplayAlerts = True
 
    shname.Name = "Date_" + A + "_Vir"
 
 
 
                                            ' remplissage des onglets
 
Dim iLI As Long
 
    Dim iRE As Long
    Dim iRA As Long
 
    Dim iLO As Long
 
    Dim LI As Worksheet
    Dim LO As Worksheet
    Dim RE As Worksheet
    Dim RA As Worksheet
 
 
    Set LI = Worksheets("Dons Chèques")
    Set LO = Worksheets("Dons Virements")
    Set RE = Worksheets("Date_" + A + "_chèques")
    Set RA = Worksheets("Date_" + A + "_Vir")
 
 
 
    iRE = 3
    iRA = 3
 
 
    For iLI = 2 To 1000
 
        If LI.Cells(iLI, 17).Text = "OK !" Then
 
            LI.Range(iLI & ":" & iLI).Copy RE.Cells(iRE, 1)
 
            iRE = iRE + 1
 
        End If
 
     Next
 
 
    For iLO = 2 To 1000
        If LO.Cells(iLO, 17).Text = "OK !" Then
 
            LO.Range(iLO & ":" & iLO).Copy RA.Cells(iRA, 1)
 
            iRA = iRA + 1
        End If
 
 
Next
End If
 
            ' deuxième filtre: par mission
 
 
Dim TheName2 As String
Dim Vol As String
Dim F As Worksheet
Dim G As Worksheet
Dim H As Worksheet
Dim R As Range
Dim FirstFound As String
Dim Plg3 As Range
Dim Plg4 As Range
 
                    'sur la feuille créée ci_avant
 
Set F = Worksheets("Date_" + A + "_chèques")
 
Mission.Show
TheName = Module1.Mission2
 If TheName = vbNullString Then
    Exit Sub
    Else
 
TheName2 = TheName
 
Set Plg3 = F.Range(F.Cells(1, 1), F.Cells(20, 1000))
 
With Plg3
 
    Set R = .Find(TheName, LookIn:=xlValues, LookAt:=xlPart)
        If Not (R Is Nothing) Then
            FirstFound = R.Address
            Do
                R.Offset(0, 15).Value = "Trouvé !"
                Set R = .FindNext(R)
            Loop While R.Address <> FirstFound
 
        Else
            MsgBox "Ce nom n'est pas répertorié", vbOKOnly, "Dons Chèques"
 
        End If
 
End With
 
    Dim shtoto6 As Worksheet
 
    Set shname = Sheets.Add(After:=Sheets(Sheets.Count))
 
Application.DisplayAlerts = False
 
For Each X In Sheets
If X.Name = TheName Then X.Delete
Next
Application.DisplayAlerts = True
 
    shname.Name = "Publip_" + TheName + "_chèques"
 
                        ' sur l'autre feuille créée ci-avant
 
Set G = Worksheets("Date_" + A + "_Vir")
Set Plg4 = G.Range(G.Cells(1, 1), G.Cells(20, 1000))
With Plg4
 
    Set R = .Find(TheName, LookIn:=xlValues, LookAt:=xlPart)
        If Not (R Is Nothing) Then
            FirstFound = R.Address
            Do
                R.Offset(0, 15).Value = "Trouvé !"
                Set R = .FindNext(R)
            Loop While R.Address <> FirstFound
 
        Else
            MsgBox "Ce nom n'est pas répertorié", vbOKOnly, "Dons Virements"
 
 
        End If
        End With
 
Dim shtoto4 As Worksheet
 
    Set shname = Sheets.Add(After:=Sheets(Sheets.Count))
 
Application.DisplayAlerts = False
 
For Each X In Sheets
If X.Name = TheName Then X.Delete
Next
Application.DisplayAlerts = True
 
    shname.Name = "Publip_" + TheName + "_Vir"
 
 
 
 
 
Dim iLW As Long
 
    Dim iRC As Long
    Dim iRD As Long
 
    Dim iLZ As Long
 
    Dim LW As Worksheet
    Dim LZ As Worksheet
    Dim RC As Worksheet
    Dim RD As Worksheet
 
 
    Set LW = Worksheets("Date_" + A + "_Chèques")
    Set LI = Worksheets("Date_" + A + "_Vir")
    Set RC = Worksheets("Publip_" + TheName + "_chèques")
    Set RD = Worksheets("Publip_" + TheName + "_Vir")
 
 
 
    iRC = 3
    iRD = 3
 
 
    For iLW = 2 To 1000
 
        If LW.Cells(iLW, 17).Text = "Trouvé !" Then
 
            LW.Range(iLW & ":" & iLW).Copy RC.Cells(iRC, 1)
 
            iRC = iRC + 1
 
        End If
 
     Next
 
 
    For iLZ = 2 To 1000
        If LZ.Cells(iLZ, 17).Text = "Trouvé !" Then
 
            LZ.Range(iLZ & ":" & iLZ).Copy RD.Cells(iRD, 1)
 
            iRD = iRD + 1
        End If
 
    Next
            ' on supprime les critères qui ont permis la sélection
 
     LW.Columns(17).Delete
     LZ.Columns(17).Delete
     RC.Columns(17).Delete
     RD.Columns(17).Delete
        ' on mets en forme les deux nouvelles feuilles créées
     RD.Range("A1:N1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
     RD.Range("A1").Value = TheName + " DONS VIREMENTS " + A
 
     RD.Range("A2").Value = "Date Transaction"
     RD.Range("B2").Value = "Mission"
     RD.Range("C2").Value = "Genre"
     RD.Range("D2").Value = "Salut"
     RD.Range("E2").Value = "Nom"
     RD.Range("F2").Value = "Prénom"
     RD.Range("G2").Value = "Mail"
     RD.Range("H2").Value = "Adresse"
     RD.Range("I2").Value = "CP"
     RD.Range("J2").Value = "Ville"
     RD.Range("K2").Value = "Pays"
     RD.Range("L2").Value = "Montant"
     RD.Range("M2").Value = "Nb Mensualités"
     RD.Range("N2").Value = "Total"
 
 
     RC.Range("A1:M1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
     RC.Range("A1").Value = TheName + " DONS CHEQUES " + A
        RE.Range("A2").Value = "Date Transaction"
     RC.Range("B2").Value = "Mission"
     RC.Range("C2").Value = "Genre"
     RC.Range("D2").Value = "Salut"
     RC.Range("E2").Value = "Nom"
     RC.Range("F2").Value = "Prénom"
     RC.Range("G2").Value = "Mail"
     RC.Range("H2").Value = "Adresse"
     RC.Range("I2").Value = "CP"
     RC.Range("J2").Value = "Ville"
     RC.Range("K2").Value = "Pays"
     RC.Range("L2").Value = "Montant"
     RC.Range("M2").Value = "Total"
 
 
End If
 
        'on dégage les deux feuilles temporairement créées
 
Application.DisplayAlerts = False
Sheets("Date_" + A + "_Vir").Delete
Sheets("Date_" + A + "_Chèques").Delete
Application.DisplayAlerts = True
 
 
End Sub

**Philippe Tulliez** · 28/01/2013, 23h12

Bonjour,
En principe le publipostage peux se faire à l'aide de Word pour la lettre et Excel comme base de données sans aucun code VBA.
Le publipostage de Word est très riche en possibilités pour faire entre autres une ou plusieurs sélections selon critères, faire un ou plusieurs tris et même faire commencer la lettre par cher, ou chère selon que le courrier s'adresse à un homme ou à une femme.
Un petit coup d'oeil sur la FAQ Word consacrée à ce sujet

**Harreauv** · 29/01/2013, 10h24

Bonjour Philippe,

Merci de cette réponse.

Je suis Newbie sur VB, pas sur le publipostage.
Mon idée est de créer une grosse macro qui accompagne la personne qui va rentrer les informations dans les différentes étapes.

La question est plutôt: comment créer une liste à partir de données que j'ai préalablement enregistré en fonction de la date d'envoi ET d'un autre critère.

Merci

**Philippe Tulliez** · 29/01/2013, 13h45

Bonjour,

Je suis Newbie sur VB, pas sur le publipostage.

Et moi un novice dans ces termes (même si j'avais deviné j'ai dû aller voir sur google ce que cela voulait dire exactement)

Newbie (prononcé [ˈnjuːbɪ] en anglais britannique, ou [ˈnuːbɪ] en anglais américain) est une personne novice, qui débute1 (notamment dans le jeu vidéo). Il peut aussi être écrit newbee, noobi, noob ou encore noubi aussi.

donc tu connais le publipostage ?

La question est plutôt: comment créer une liste à partir de données que j'ai préalablement enregistré en fonction de la date d'envoi ET d'un autre critère.

Un filtre par exemple ?
Qui existe dans le publipostage et dans excel mais sans doute je n'ai pas compris la finalité de ton projet.

VBA Copier donnée si date = et autre condition

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager