[XL-2010] Extraction du mois d'une Date

Extraction du mois d'une Date

Bonjour à tous!

Je débute en programmation VBA et je bloque sur un probleme qui à priori ne devrait pas être trop compliqué...
Je souhaite entrer un mois de l'année (entre 01 et 12) et ensuite recopier des lignes d'une feuille (DCD) à une autre (BUF) si le mois de la date de la ligne en question (qui se trouve en premiere case) correspond au mois entré.
J#ai essayé pas mal de chose (Format, Month, ...) que j'ai trouvé sur le net, mais rien y fait, je n'arrive pas à lire uniquement le mois de ma date...

Voici mon code:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Dim Whichmonth As String Dim VraieLigneBUF As Double Whichmonth = InputBox("Enter Month" & vbCrLf & vbCrLf, "forum Access") VraieLigneDCD = 3 VraieLigneBUF = 3 While Not (IsEmpty(wsDCD.Cells(VraieLigneDCD, 1))) If Month(wsDCD.Cells(VraieLigneDCD, 1)) = Whichmonth Then wsBUF.Range("A" & VraieLigneBUF & ":" & "P" & VraieLigneBUF).Value = wsDCD.Range("A" & VraieLigneDCD & ":" & "P" & VraieLigneDCD).Value VraieLigneBUF = VraieLigneBUF + 1 End If VraieLigneDCD = VraieLigneDCD + 1 Wend
Merci d'avance à tous ceux qui prendront le temps de me répondre!

Eric

Month(tadate)
a noter qu'il te renvoit un entier de 1 à 12.

Donc si tu veux tester avec 01 il va falloir faire du retraitement..

Code:

cint(right("01",1))

Salut,

Merci pour ta réponse, quelle rapidité!
Mais le probleme ne vient pas de là car même si je rentre "1", cela ne fonctionne pas.
De plus, j'ai essayé d'afficher (pour tester) avant de rentrer dans la boucle le résultat de la fonction Month(ma cellule...) et jài un message d'erreur.
Avec la fonction Format(ma celulle, "mm"), il ne m'affiche pas le mois, mais la date entière...

Tu compares des chiens à des chats, prends l'habitude de vérifier les formats des variables que tu utilises

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Dim Whichmonth As String
Dim VraieLigneBUF As Double
 
Whichmonth = InputBox("Enter Month" & vbCrLf & vbCrLf, "forum Access")
 
VraieLigneDCD = 3
VraieLigneBUF = 3
While Not (IsEmpty(wsDCD.Cells(VraieLigneDCD, 1)))
   If Month(cdate(wsDCD.Cells(VraieLigneDCD, 1))) = cint(Whichmonth) Then
        wsBUF.Range("A" & VraieLigneBUF & ":" & "P" & VraieLigneBUF).Value = wsDCD.Range("A" & VraieLigneDCD & ":" & "P" & VraieLigneDCD).Value
        VraieLigneBUF = VraieLigneBUF + 1
    End If
VraieLigneDCD = VraieLigneDCD + 1
Wend

J'avais également pensé au format en ajoutant cdate devant ma cellule...
Mais ca ne fonctionne toujours pas.
Toujours la même erreur : "Run-time error '13' Type mismatch"

(PS: j'ai qd meme pris le temps de rentrer tes corrections et d'essayer avant de te répondre)

Bon... Chez moi ça marche.. File ton classeur

1 pièce(s) jointe(s)

Je te préviens, j'ai commencé la programmation y'a une semaine...
J'espère que tu arriveras à t'y retrouver!

Code:

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
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
Private Sub StartMacroContract()
'-----------------------------------------------------------------------------
'Declarations
'-----------------------------------------------------------------------------
Dim wb As Workbook
Dim ws As Worksheet
 
Dim DureeJour As Integer
Dim DureeMois As Integer
Dim DureeQuartal As Integer
Dim DureeAnnee As Integer
Dim VraieLigne As Integer
Dim CritereArret As Integer
Dim Buffer As Date
Dim dLigneOffset As Double
Dim dColumnOffset As Double
Dim VraieLigneDR As Double
Dim VraieLigneDCT As Double
Dim dLigneBG As Double
Dim LignePrevious As Double
 
 
'-----------------------------------------------------------------------------
'Settings
'-----------------------------------------------------------------------------
'First row to import data.
dLigneOffset = 2
dColumnOffset = 1
dLigneDCTOffset = 3
dLigneDCDOffset = 3
dLigneDCYOffset = 3
 
'Set workbook.
Set wb = Me.Application.ActiveWorkbook
Set wsDR = wb.Worksheets("Data Raw OCB")
Set wsBG = wb.Worksheets("Data Raw BG (MAM)")
Set wsDCT = wb.Worksheets("Data Contract Type")
Set wsDCD = wb.Worksheets("Data Contract 2013")
Set wsDCY = wb.Worksheets("Data Contract 2014")
Set wsDCP = wb.Worksheets("Data Contract Previous")
Set wsBUF = wb.Worksheets("Data Contract Buffer")
 
 
'-----------------------------------------------------------------------------
'Code 1
'-----------------------------------------------------------------------------
 
'Errase Data
wsDCT.Range("A3:U100000").ClearContents
wsDCD.Range("A3:U100000").ClearContents
wsDCY.Range("A3:U100000").ClearContents
wsBUF.Range("A3:U100000").ClearContents
 
VraieLigneDR = dLigneOffset
VraieLigneDCT = dLigneDCTOffset
 
    While Not (IsEmpty(wsDR.Cells(VraieLigneDR, dColumnOffset)))
 
 
    DureeJour = wsDR.Cells(VraieLigneDR, dColumnOffset + 1) - wsDR.Cells(VraieLigneDR, dColumnOffset)
    DureeAnnee = Year(wsDR.Cells(VraieLigneDR, dColumnOffset + 1)) - Year(wsDR.Cells(VraieLigneDR, dColumnOffset))
    DureeQuartal = ((Year(wsDR.Cells(VraieLigneDR, dColumnOffset + 1)) - Year(wsDR.Cells(VraieLigneDR, dColumnOffset))) * 12 + Month(wsDR.Cells(VraieLigneDR, dColumnOffset + 1)) - Month(wsDR.Cells(VraieLigneDR, dColumnOffset))) / 3
    DureeMois = ((Year(wsDR.Cells(VraieLigneDR, dColumnOffset + 1)) - Year(wsDR.Cells(VraieLigneDR, dColumnOffset))) * 12 + Month(wsDR.Cells(VraieLigneDR, dColumnOffset + 1)) - Month(wsDR.Cells(VraieLigneDR, dColumnOffset)))
 
       If InStr(wsDR.Cells(VraieLigneDR, dColumnOffset + 5).Value, "VUE") Then
          wsDCT.Cells(VraieLigneDCT, 1).Value = wsDR.Cells(VraieLigneDR, 1).Value
          wsDCT.Cells(VraieLigneDCT, 2).Value = "<2013"
          wsDCT.Cells(VraieLigneDCT, 3).Value = "1"
          wsDCT.Cells(VraieLigneDCT, 4).Value = DureeJour
          wsDCT.Range("E" & VraieLigneDCT & ":" & "S" & VraieLigneDCT).Value = wsDR.Range("B" & VraieLigneDR & ":" & "Q" & VraieLigneDR).Value
       Else
           If InStr(wsDR.Cells(VraieLigneDR, dColumnOffset).Value, "10/1/") And InStr(wsDR.Cells(VraieLigneDR, dColumnOffset + 1).Value, "10/1/") Then
              wsDCT.Cells(VraieLigneDCT, 1).Value = wsDR.Cells(VraieLigneDR, 1).Value
              wsDCT.Cells(VraieLigneDCT, 2).Value = "Y"
              wsDCT.Cells(VraieLigneDCT, 3).Value = DureeAnnee
              wsDCT.Cells(VraieLigneDCT, 4).Value = DureeJour
              wsDCT.Range("E" & VraieLigneDCT & ":" & "S" & VraieLigneDCT).Value = wsDR.Range("B" & VraieLigneDR & ":" & "Q" & VraieLigneDR).Value
           Else
               If (InStr(wsDR.Cells(VraieLigneDR, dColumnOffset).Value, "10/1/") Or InStr(wsDR.Cells(VraieLigneDR, dColumnOffset).Value, "7/1/") Or InStr(wsDR.Cells(VraieLigneDR, dColumnOffset).Value, "4/1/") Or InStr(wsDR.Cells(VraieLigneDR, dColumnOffset).Value, "1/1/")) And (InStr(wsDR.Cells(VraieLigneDR, dColumnOffset + 1).Value, "10/1/") Or InStr(wsDR.Cells(VraieLigneDR, dColumnOffset + 1).Value, "7/1/") Or InStr(wsDR.Cells(VraieLigneDR, dColumnOffset + 1).Value, "4/1/") Or InStr(wsDR.Cells(VraieLigneDR, dColumnOffset + 1).Value, "1/1/")) Then
                  wsDCT.Cells(VraieLigneDCT, 1).Value = wsDR.Cells(VraieLigneDR, 1).Value
                  wsDCT.Cells(VraieLigneDCT, 2).Value = "Q"
                  wsDCT.Cells(VraieLigneDCT, 3).Value = DureeQuartal
                  wsDCT.Cells(VraieLigneDCT, 4).Value = DureeJour
                  wsDCT.Range("E" & VraieLigneDCT & ":" & "S" & VraieLigneDCT).Value = wsDR.Range("B" & VraieLigneDR & ":" & "Q" & VraieLigneDR).Value
               Else
                   If Day(wsDR.Cells(VraieLigneDR, dColumnOffset)) = 1 And Day(wsDR.Cells(VraieLigneDR, dColumnOffset + 1)) = 1 Then
                       wsDCT.Cells(VraieLigneDCT, 1).Value = wsDR.Cells(VraieLigneDR, 1).Value
                       wsDCT.Cells(VraieLigneDCT, 2).Value = "M"
                       wsDCT.Cells(VraieLigneDCT, 3).Value = DureeMois
                       wsDCT.Cells(VraieLigneDCT, 4).Value = DureeJour
                       wsDCT.Range("E" & VraieLigneDCT & ":" & "S" & VraieLigneDCT).Value = wsDR.Range("B" & VraieLigneDR & ":" & "Q" & VraieLigneDR).Value
                   Else
                       wsDCT.Cells(VraieLigneDCT, 1).Value = wsDR.Cells(VraieLigneDR, 1).Value
                       wsDCT.Cells(VraieLigneDCT, 2).Value = "D"
                       wsDCT.Cells(VraieLigneDCT, 3).Value = DureeJour
                       wsDCT.Cells(VraieLigneDCT, 4).Value = DureeJour
                       wsDCT.Range("E" & VraieLigneDCT & ":" & "S" & VraieLigneDCT).Value = wsDR.Range("B" & VraieLigneDR & ":" & "Q" & VraieLigneDR).Value
                   End If
               End If
           End If
       End If
 
'Create Quality Type UK
       If wsDCT.Cells(VraieLigneDCT, 15).Value = "FZK" Then
           wsDCT.Cells(VraieLigneDCT, 20).Value = "FZK"
           Else
                If wsDCT.Cells(VraieLigneDCT, 15).Value = "DZK" Then
                wsDCT.Cells(VraieLigneDCT, 20).Value = "DZK"
                     Else
                          If wsDCT.Cells(VraieLigneDCT, 15).Value = "UK" Then
                               If wsDCT.Cells(VraieLigneDCT, 2).Value = "<2013" Then
                                     wsDCT.Cells(VraieLigneDCT, 20).Value = "UK1"
                                     Else
                                          If wsDCT.Cells(VraieLigneDCT, 2).Value = "Y" Then
                                           wsDCT.Cells(VraieLigneDCT, 20).Value = "UK1"
                                           Else
                                               If wsDCT.Cells(VraieLigneDCT, 2).Value = "Q" Then
                                               wsDCT.Cells(VraieLigneDCT, 20).Value = "UK2"
                                               Else
                                                    If wsDCT.Cells(VraieLigneDCT, 2).Value = "M" Then
                                                    wsDCT.Cells(VraieLigneDCT, 20).Value = "UK3"
                                                    Else
                                                        If wsDCT.Cells(VraieLigneDCT, 2).Value = "D" Then
                                                        wsDCT.Cells(VraieLigneDCT, 20).Value = "UK4"
                                                        End If
                                                    End If
                                                End If
                                            End If
                                End If
                          End If
                End If
        End If
 
'Change the name of the Point(as GMS nomenclature)
       If wsDCT.Cells(VraieLigneDCT, 16).Value = "BBOG" Then
           wsDCT.Cells(VraieLigneDCT, 17).Value = "Baumgarten"
           Else
                If wsDCT.Cells(VraieLigneDCT, 16).Value = "OBER" Then
                    wsDCT.Cells(VraieLigneDCT, 17).Value = "Oberkappel"
                     Else
                          If wsDCT.Cells(VraieLigneDCT, 16).Value = "BMAB" Then
                              wsDCT.Cells(VraieLigneDCT, 17).Value = "MAB"
                          End If
                End If
        End If
 
'Create the Entry/Exit + Point Code
        wsDCT.Cells(VraieLigneDCT, 18).Value = wsDCT.Cells(VraieLigneDCT, 14).Value & " " & wsDCT.Cells(VraieLigneDCT, 17).Value
 
'Recherche Code BG and Copy value
        dLigneBG = 2
        While Not (wsDCT.Cells(VraieLigneDCT, 19).Value = wsBG.Cells(dLigneBG - 1, 5).Value)
        If wsDCT.Cells(VraieLigneDCT, 12).Value = wsBG.Cells(dLigneBG, 3).Value Then
           wsDCT.Cells(VraieLigneDCT, 19).Value = wsBG.Cells(dLigneBG, 5).Value
        End If
        dLigneBG = dLigneBG + 1
        Wend
 
    VraieLigneDCT = VraieLigneDCT + 1
    VraieLigneDR = VraieLigneDR + 1
 
    Wend
 
'-----------------------------------------------------------------------------
'Code 2 (Identification of the changes)
'-----------------------------------------------------------------------------
VraieLigneDR = 3
 
While Not (IsEmpty(wsDCT.Cells(VraieLigneDR, 1)))
 
   LignePrevious = 3
   While Not IsEmpty(wsDCP.Cells(LignePrevious, 1))
     If IsEmpty(wsDCT.Cells(VraieLigneDR, 21)) Then
        If wsDCT.Cells(VraieLigneDR, 1).Value = wsDCP.Cells(LignePrevious, 1) And wsDCT.Cells(VraieLigneDR, 5).Value = wsDCP.Cells(LignePrevious, 5) _
        And wsDCT.Cells(VraieLigneDR, 7).Value = wsDCP.Cells(LignePrevious, 7) And wsDCT.Cells(VraieLigneDR, 9).Value = wsDCP.Cells(LignePrevious, 9) _
        And wsDCT.Cells(VraieLigneDR, 20).Value = wsDCP.Cells(LignePrevious, 20) And wsDCT.Cells(VraieLigneDR, 12).Value = wsDCP.Cells(LignePrevious, 12) And wsDCT.Cells(VraieLigneDR, 13).Value = wsDCP.Cells(LignePrevious, 13) Then
            wsDCT.Cells(VraieLigneDR, 21).Value = "No Change"
        End If
     End If
     LignePrevious = LignePrevious + 1
   Wend
 
   LignePrevious = 3
   If IsEmpty(wsDCT.Cells(VraieLigneDR, 21)) Then
   While Not IsEmpty(wsDCP.Cells(LignePrevious, 1))
     If IsEmpty(wsDCT.Cells(VraieLigneDR, 21)) Then
        If wsDCT.Cells(VraieLigneDR, 1).Value = wsDCP.Cells(LignePrevious, 1) And wsDCT.Cells(VraieLigneDR, 5).Value = wsDCP.Cells(LignePrevious, 5) _
        And wsDCT.Cells(VraieLigneDR, 7).Value = wsDCP.Cells(LignePrevious, 7) And wsDCT.Cells(VraieLigneDR, 9).Value = wsDCP.Cells(LignePrevious, 9) _
        And wsDCT.Cells(VraieLigneDR, 20).Value = wsDCP.Cells(LignePrevious, 20) And wsDCT.Cells(VraieLigneDR, 12).Value = wsDCP.Cells(LignePrevious, 12) Then
            wsDCT.Cells(VraieLigneDR, 21).Value = "Allocation Change"
        End If
     End If
   LignePrevious = LignePrevious + 1
   Wend
   End If
 
   LignePrevious = 3
   If IsEmpty(wsDCT.Cells(VraieLigneDR, 21)) Then
   While Not IsEmpty(wsDCP.Cells(LignePrevious, 1))
     If IsEmpty(wsDCT.Cells(VraieLigneDR, 21)) Then
        If wsDCT.Cells(VraieLigneDR, 1).Value = wsDCP.Cells(LignePrevious, 1) And wsDCT.Cells(VraieLigneDR, 5).Value = wsDCP.Cells(LignePrevious, 5) _
        And wsDCT.Cells(VraieLigneDR, 7).Value = wsDCP.Cells(LignePrevious, 7) And wsDCT.Cells(VraieLigneDR, 9).Value = wsDCP.Cells(LignePrevious, 9) _
        And wsDCT.Cells(VraieLigneDR, 20).Value = wsDCP.Cells(LignePrevious, 20) Then
            wsDCT.Cells(VraieLigneDR, 21).Value = "BG Change"
        End If
     End If
    LignePrevious = LignePrevious + 1
    Wend
    End If
 
    If IsEmpty(wsDCT.Cells(VraieLigneDR, 21)) Then
        wsDCT.Cells(VraieLigneDR, 21).Value = "New Contract"
    End If
 
VraieLigneDR = VraieLigneDR + 1
Wend
 
'-----------------------------------------------------------------------------
'Code 3 (Contract repartition)
'-----------------------------------------------------------------------------
 
VraieLigneDR = dLigneOffset
VraieLigneDCT = dLigneDCTOffset
VraieLigneDCD = dLigneDCDOffset
VraieLigneDCY = dLigneDCYOffset
 
While Not (IsEmpty(wsDR.Cells(VraieLigneDR, dColumnOffset)))
   Buffer = wsDR.Cells(VraieLigneDR, 1).Value
   If wsDR.Cells(VraieLigneDR, 2).Value <= #1/1/2014# Then
        While Buffer <> 1 / 1 / 2014 And Buffer <> wsDR.Cells(VraieLigneDR, 2).Value
           wsDCD.Cells(VraieLigneDCD, 1).Value = Format(Buffer, "dd.mm.yyyy")
           wsDCD.Range("B" & VraieLigneDCD & ":" & "S" & VraieLigneDCD).Value = wsDR.Range("C" & VraieLigneDR & ":" & "T" & VraieLigneDR).Value
 
'Change the name of the Point(as GMS nomenclature)
       If wsDCD.Cells(VraieLigneDCD, 12).Value = "BBOG" Then
           wsDCD.Cells(VraieLigneDCD, 13).Value = "Baumgarten"
           Else
                If wsDCD.Cells(VraieLigneDCD, 12).Value = "OBER" Then
                    wsDCD.Cells(VraieLigneDCD, 13).Value = "Oberkappel"
                     Else
                          If wsDCD.Cells(VraieLigneDCD, 12).Value = "BMAB" Then
                              wsDCD.Cells(VraieLigneDCD, 13).Value = "MAB"
                          End If
                End If
        End If
 
'Create the Entry/Exit + Point Code
        wsDCD.Cells(VraieLigneDCD, 14).Value = wsDCD.Cells(VraieLigneDCD, 10).Value & " " & wsDCD.Cells(VraieLigneDCD, 13).Value
 
'Recherche Code BG and Copy value
        dLigneBG = 2
        While Not (wsDCD.Cells(VraieLigneDCD, 15).Value = wsBG.Cells(dLigneBG - 1, 5).Value)
        If wsDCD.Cells(VraieLigneDCD, 8).Value = wsBG.Cells(dLigneBG, 3).Value Then
           wsDCD.Cells(VraieLigneDCD, 15).Value = wsBG.Cells(dLigneBG, 5).Value
        End If
        dLigneBG = dLigneBG + 1
        Wend
 
'Create Quality Type UK
       If wsDCD.Cells(VraieLigneDCD, 11).Value = "FZK" Then
           wsDCD.Cells(VraieLigneDCD, 16).Value = "FZK"
           Else
                If wsDCD.Cells(VraieLigneDCD, 11).Value = "DZK" Then
                wsDCD.Cells(VraieLigneDCD, 16).Value = "DZK"
                     Else
                          If wsDCD.Cells(VraieLigneDCD, 11).Value = "UK" Then
                               If wsDCT.Cells(VraieLigneDR, 2).Value = "<2013" Then
                                     wsDCD.Cells(VraieLigneDCD, 16).Value = "UK1"
                                     Else
                                          If wsDCT.Cells(VraieLigneDR, 2).Value = "Y" Then
                                           wsDCD.Cells(VraieLigneDCD, 16).Value = "UK1"
                                           Else
                                               If wsDCT.Cells(VraieLigneDR, 2).Value = "Q" Then
                                               wsDCD.Cells(VraieLigneDCD, 16).Value = "UK2"
                                               Else
                                                    If wsDCT.Cells(VraieLigneDR, 2).Value = "M" Then
                                                    wsDCD.Cells(VraieLigneDCD, 16).Value = "UK3"
                                                    Else
                                                        If wsDCT.Cells(VraieLigneDR, 2).Value = "D" Then
                                                        wsDCD.Cells(VraieLigneDCD, 16).Value = "UK4"
                                                        End If
                                                    End If
                                                End If
                                            End If
                                End If
                          End If
                End If
        End If
 
 
           Buffer = Buffer + 1
           VraieLigneDCD = VraieLigneDCD + 1
        Wend
 
 
 
        Else
            If wsDR.Cells(VraieLigneDR, 1).Value < #1/1/2014# Then
              While Buffer <> #1/1/2014#
                wsDCD.Cells(VraieLigneDCD, 1).Value = Format(Buffer, "dd.mm.yyyy")
                wsDCD.Range("B" & VraieLigneDCD & ":" & "S" & VraieLigneDCD).Value = wsDR.Range("C" & VraieLigneDR & ":" & "T" & VraieLigneDR).Value
 
'Change the name of the Point(as GMS nomenclature)
       If wsDCD.Cells(VraieLigneDCD, 12).Value = "BBOG" Then
           wsDCD.Cells(VraieLigneDCD, 13).Value = "Baumgarten"
           Else
                If wsDCD.Cells(VraieLigneDCD, 12).Value = "OBER" Then
                    wsDCD.Cells(VraieLigneDCD, 13).Value = "Oberkappel"
                     Else
                          If wsDCD.Cells(VraieLigneDCD, 12).Value = "BMAB" Then
                              wsDCD.Cells(VraieLigneDCD, 13).Value = "MAB"
                          End If
                End If
        End If
 
'Create the Entry/Exit + Point Code
        wsDCD.Cells(VraieLigneDCD, 14).Value = wsDCD.Cells(VraieLigneDCD, 10).Value & " " & wsDCD.Cells(VraieLigneDCD, 13).Value
 
'Recherche Code BG and Copy value
        dLigneBG = 2
        While Not (wsDCD.Cells(VraieLigneDCD, 15).Value = wsBG.Cells(dLigneBG - 1, 5).Value)
        If wsDCD.Cells(VraieLigneDCD, 8).Value = wsBG.Cells(dLigneBG, 3).Value Then
           wsDCD.Cells(VraieLigneDCD, 15).Value = wsBG.Cells(dLigneBG, 5).Value
        End If
        dLigneBG = dLigneBG + 1
        Wend
 
 'Create Quality Type UK
       If wsDCD.Cells(VraieLigneDCD, 11).Value = "FZK" Then
           wsDCD.Cells(VraieLigneDCD, 16).Value = "FZK"
           Else
                If wsDCD.Cells(VraieLigneDCD, 11).Value = "DZK" Then
                wsDCD.Cells(VraieLigneDCD, 16).Value = "DZK"
                     Else
                          If wsDCD.Cells(VraieLigneDCD, 11).Value = "UK" Then
                               If wsDCT.Cells(VraieLigneDR, 2).Value = "<2013" Then
                                     wsDCD.Cells(VraieLigneDCD, 16).Value = "UK1"
                                     Else
                                          If wsDCT.Cells(VraieLigneDR, 2).Value = "Y" Then
                                           wsDCD.Cells(VraieLigneDCD, 16).Value = "UK1"
                                           Else
                                               If wsDCT.Cells(VraieLigneDR, 2).Value = "Q" Then
                                               wsDCD.Cells(VraieLigneDCD, 16).Value = "UK2"
                                               Else
                                                    If wsDCT.Cells(VraieLigneDR, 2).Value = "M" Then
                                                    wsDCD.Cells(VraieLigneDCD, 16).Value = "UK3"
                                                    Else
                                                        If wsDCT.Cells(VraieLigneDR, 2).Value = "D" Then
                                                        wsDCD.Cells(VraieLigneDCD, 16).Value = "UK4"
                                                        End If
                                                    End If
                                                End If
                                            End If
                                End If
                          End If
                End If
        End If
 
                Buffer = Buffer + 1
                VraieLigneDCD = VraieLigneDCD + 1
              Wend
 
    While Buffer < wsDR.Cells(VraieLigneDR, 2).Value
        wsDCY.Cells(VraieLigneDCY, 1).Value = Format(Buffer, "mm/yyyy")
        wsDCY.Range("B" & VraieLigneDCY & ":" & "S" & VraieLigneDCY).Value = wsDR.Range("C" & VraieLigneDR & ":" & "T" & VraieLigneDR).Value
 
'Change the name of the Point(as GMS nomenclature)
       If wsDCY.Cells(VraieLigneDCY, 12).Value = "BBOG" Then
           wsDCY.Cells(VraieLigneDCY, 13).Value = "Baumgarten"
           Else
                If wsDCY.Cells(VraieLigneDCY, 12).Value = "OBER" Then
                    wsDCY.Cells(VraieLigneDCY, 13).Value = "Oberkappel"
                     Else
                          If wsDCY.Cells(VraieLigneDCY, 12).Value = "BMAB" Then
                              wsDCY.Cells(VraieLigneDCY, 13).Value = "MAB"
                          End If
                End If
        End If
 
'Create the Entry/Exit + Point Code
        wsDCY.Cells(VraieLigneDCY, 14).Value = wsDCY.Cells(VraieLigneDCY, 10).Value & " " & wsDCY.Cells(VraieLigneDCY, 13).Value
 
'Recherche Code BG and Copy value
        dLigneBG = 2
        While Not (wsDCY.Cells(VraieLigneDCY, 15).Value = wsBG.Cells(dLigneBG - 1, 5).Value)
        If wsDCY.Cells(VraieLigneDCY, 8).Value = wsBG.Cells(dLigneBG, 3).Value Then
           wsDCY.Cells(VraieLigneDCY, 15).Value = wsBG.Cells(dLigneBG, 5).Value
        End If
        dLigneBG = dLigneBG + 1
        Wend
 
                Buffer = DateAdd("m", 1, Buffer)
                VraieLigneDCY = VraieLigneDCY + 1
              Wend
            Else
               If wsDR.Cells(VraieLigneDR, 1).Value >= #1/1/2014# Then
                   While Buffer < wsDR.Cells(VraieLigneDR, 2).Value
                      wsDCY.Cells(VraieLigneDCY, 1).Value = Format(Buffer, "mm/yyyy")
                      wsDCY.Range("B" & VraieLigneDCY & ":" & "S" & VraieLigneDCY).Value = wsDR.Range("C" & VraieLigneDR & ":" & "T" & VraieLigneDR).Value
 
'Change the name of the Point(as GMS nomenclature)
       If wsDCY.Cells(VraieLigneDCY, 12).Value = "BBOG" Then
           wsDCY.Cells(VraieLigneDCY, 13).Value = "Baumgarten"
           Else
                If wsDCY.Cells(VraieLigneDCY, 12).Value = "OBER" Then
                    wsDCY.Cells(VraieLigneDCY, 13).Value = "Oberkappel"
                     Else
                          If wsDCY.Cells(VraieLigneDCY, 12).Value = "BMAB" Then
                              wsDCY.Cells(VraieLigneDCY, 13).Value = "MAB"
                          End If
                End If
        End If
 
'Create the Entry/Exit + Point Code
        wsDCY.Cells(VraieLigneDCY, 14).Value = wsDCY.Cells(VraieLigneDCY, 10).Value & " " & wsDCY.Cells(VraieLigneDCY, 13).Value
 
'Recherche Code BG and Copy value
        dLigneBG = 2
        While Not (wsDCY.Cells(VraieLigneDCY, 15).Value = wsBG.Cells(dLigneBG - 1, 5).Value)
        If wsDCY.Cells(VraieLigneDCY, 8).Value = wsBG.Cells(dLigneBG, 3).Value Then
           wsDCY.Cells(VraieLigneDCY, 15).Value = wsBG.Cells(dLigneBG, 5).Value
        End If
        dLigneBG = dLigneBG + 1
        Wend
 
                      Buffer = DateAdd("m", 1, Buffer)
                      VraieLigneDCY = VraieLigneDCY + 1
                   Wend
               End If
            End If
    End If
   VraieLigneDR = VraieLigneDR + 1
Wend
 
'Create the Buffer Sheet with value on the current month
 
Dim Whichmonth As String
Dim VraieLigneBUF As Double
 
Whichmonth = InputBox("Enter Month" & vbCrLf & vbCrLf, "forum Access")
 
VraieLigneDCD = 3
VraieLigneBUF = 3
'wsBUF.Cells(VraieLigneBUF, 1).Value = Month(CDate(wsDCD.Cells(VraieLigneDCD, 1)))
While Not (IsEmpty(wsDCD.Cells(VraieLigneDCD, 1)))
   If Month(CDate(wsDCD.Cells(VraieLigneDCD, 1))) = CInt(Whichmonth) Then
        wsBUF.Range("A" & VraieLigneBUF & ":" & "P" & VraieLigneBUF).Value = wsDCD.Range("A" & VraieLigneDCD & ":" & "P" & VraieLigneDCD).Value
        VraieLigneBUF = VraieLigneBUF + 1
    End If
VraieLigneDCD = VraieLigneDCD + 1
Wend
 
End Sub

Bonjour, dans ton code remplace:

Code:

If Month(cdate(wsDCD.Cells(VraieLigneDCD, 1))) = cint(Whichmonth) Then

par:

Code:

If Month(CDate(Replace(wsDCD.Cells(VraieLigneDCD, 1).Value, ".", "/"))) = CByte(Whichmonth) Then

Le but de la manœuvre est de remplacer les "." de la date par des "/" du coup plus d'erreur

Y'a du mieux, mais c'est pas encore tout à fait ca!
Avec ta proposition, plus d'erreur, en revanche, la condition est remplie si le mois est bon, mais également si le jour est bon (si je rentre 1 ou 01 par exemple, il m'affiche bien toutes les lignes avec les dates du mois de janvier mais egalement toutes les 1er de chaque mois)!

J'ai trouvé une parade, mais bon, c'est du bricolage:

Code:

If Mid(wsDCD.Cells(VraieLigneDCD, 1), 4, 2) = CByte(Whichmonth) Then

Ca marche correctement, mais je prefererai fonctionner avec une condition sur la lecture du mois de ma date!

Merci pour ta réponse.