Lister tous les mercredis, les 2èmes et 4èmes samedis de l'année

[cibleo]

Bonsoir le forum,

Dans le module1, j'ai placé cette macro qui me permet de lister tous les 2èmes et 4èmes samedis de chaque mois de l'année 2011.
J'aimerais y glisser tous les mercredis de l'année 2011 et ce dans l'ordre chronologique, pouvez-vous m'aider ?

Sub Deuxieme_Quatrieme_Samedi()
Dim i As Byte, n As Byte
n = 1
For i = 1 To 12
  With Cells(n, 2)
    .Value = Sam2(2011, i)
    .NumberFormat = "dddd dd mmmm yyyy"
  End With
  With Cells(n, 2).Offset(1, 0)
    .Value = Sam4(2011, i)
    .NumberFormat = "dddd dd mmmm yyyy"
  End With
  n = n + 2
Next i
End Sub
 
Public Function Sam2(ByVal annee As Integer, ByVal mois As Byte)
Dim datef As Date
If mois > 12 Then Exit Function
datef = DateSerial(annee, mois, 1)
If Weekday(datef, vbSaturday) = 1 Then
    Sam2 = DateSerial(annee, mois, 8)
Else
    Sam2 = DateAdd("d", datef, 15 - Weekday(datef, vbSaturday))
End If
End Function
 
Public Function Sam4(ByVal annee As Integer, ByVal mois As Byte)
Dim datef As Date
If mois > 12 Then Exit Function
datef = DateSerial(annee, mois, 1)
If Weekday(datef, vbSaturday) = 1 Then
    Sam4 = DateSerial(annee, mois, 22)
Else
    Sam4 = DateAdd("d", datef, 29 - Weekday(datef, vbSaturday))
End If
End Function

D'avance merci Cibleo

 

[Grand Chaman Excel]

Re : Lister tous les mercredis, les 2èmes et 4èmes samedis de l'année

Bonsoir Cibleo,

De cette façon peut-être en recherchant d'abord les samedis, puis les mercredi et finalement en faisant un tri...

Sub Deuxieme_Quatrieme_Samedi()
Dim i As Byte, n As Byte
Dim j As Byte
n = 1

'2e samedi
For i = 1 To 12
    Set rg = Range("B65000").End(xlUp).Offset(1, 0) 'dernière cellule, colonne B
    With rg
    .Value = Sam2(2011, i)
    .NumberFormat = "dddd dd mmmm yyyy"
  End With
Next i

'4e samedi
For i = 1 To 12
    Set rg = Range("B65000").End(xlUp).Offset(1, 0) 'dernière cellule, colonne B
    With rg
    .Value = Sam4(2011, i)
    .NumberFormat = "dddd dd mmmm yyyy"
  End With
Next i
  
'Mercredi
For i = 1 To 12
    For j = 1 To 31
    If Weekday(DateSerial(2011, i, j)) = 4 Then
        Set rg = Range("B65000").End(xlUp).Offset(1, 0) 'dernière cellule, colonne B
        With rg
            .Value = DateSerial(2011, i, j)
            .NumberFormat = "dddd dd mmmm yyyy"
        End With
    End If
  Next j
Next i

'trier
Range("B1:B" & Range("B65536").End(xlUp).Row).Sort key1:=Range("B1"), order1:=xlAscending

End Sub

A+

 

[cibleo]

Re : Lister tous les mercredis, les 2èmes et 4èmes samedis de l'année

Bonjour CGE et merci,
Bonjour à tous,

C'est plus clair comme ça, 3 boucles For et un tri par ordre chronologique à la fin.
Au départ, j'imaginais incrémenter les mercredis et samedis successivement comme dans ma 1ère macro. 😛

Selon les mois, peuvent se glisser 2 ou 3 mercredis entre le 4ème samedi du mois M et le 2ème samedi du mois M + 1
C'était le casse-tête assuré 😛

Au plaisir Cibleo