Comptage et enregistrements de date nom de jour identique

Salut

Suite à nettoyage d'un disque dur ancien, avant de le jeter, un code qui pourrait être utile.

2 codes complémentaires, recherche de dates pour un nom de jour de la semaine sur une période définie.
Année en cours définie par la date de départ à fin de la même l'année

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
        'Numéro du jour par apport à son nom
        '0=Dimanche, 1=Lundi,.....,6=Samedi
Option explicit
 
Dim T ' indice pour les boucles
Dim NumJourRechercher: NumJourRechercher = 3 '  3 pour Mardi, numéro nom du jour a rechercher
Dim TblDateRechercher() ' tableau qui contiendra les dates du jour de la semaine a rechercher
 
Dim DatePremierJour: DatePremierJour = now ' ici on prend la date du jour
Dim AnnEnCours: AnnEnCours = Year(DatePremierJour)
 
If Weekday(DatePremierJour) <> NumJourRechercher Then
        'premiére boucle pour trouver le premier mardi suivant la date du jour
        For T=1 To 6
                If Weekday(DateAdd("d", 1, DatePremierJour+T)) = NumJourRechercher and Year(DatePremierJour) = AnnEnCours Then
                        'DatePremierJour+T est un mardi, retient la date
                        Redim TblDateRechercher(1)'agrandi la variable tableau en conservant les données des indices déjà existants
                        TblDateRechercher(0)= FormatDateTime(DateAdd("d", 1, DatePremierJour+T),2)
                        Exit For ' sortie de la boucle
                End If
        Next
        Else
        'la date du premier jour est un mardi, retient la date
        TblDateRechercher(0)= DateAdd("d", 1, DatePremierJour)
End If
 
'boucle sur le restant de l'année en cours
Dim DateBoucle2: DateBoucle2 = Cdate(TblDateRechercher(0))+7
Dim DatePlus1An: DatePlus1An = Cdate(FormatDateTime(DateAdd("yyyy",1,DatePremierJour),2))
'msgbox DatePlus1An
For T = DateBoucle2 To DatePlus1An step 7
        If Year(T) = AnnEnCours Then
                'msgbox Ubound(TblDateRechercher)
                Redim Preserve TblDateRechercher(Ubound(TblDateRechercher)+1)
                'msgbox Ubound(TblDateRechercher)
                TblDateRechercher(Ubound(TblDateRechercher)-1)=T
                Else
                'si Year(T) <> AnnEnCours
                Exit For
        End If
        'msgbox T
Next
'TblDateRechercher contient maintenant la totalitée des dates recherchées, correspondant au nom du jour de la semaine
 
'Vérification
msgbox "il y a " & Ubound(TblDateRechercher) & " mardi(s) d'ici la fin de l'année en cours"
Dim U: U=Ubound(TblDateRechercher)
For T = 0 to Ubound(TblDateRechercher)-1
        msgbox TblDateRechercher(t)& " date " & (T+1) & " sur " & U
Next

de date de départ à date de départ plus un an

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
        'Numéro du jour par apport à son nom
        '0=Dimanche, 1=Lundi,.....,6=Samedi
Option explicit
 
Dim T ' indice pour les boucles
Dim NumJourRechercher: NumJourRechercher = 3 '  3 pour Mardi, numéro nom du jour a rechercher
Dim TblDateRechercher() ' tableau qui contiendra les dates du jour a rechercher
 
Dim DatePremierJour: DatePremierJour = now ' ici on prend la date du jour
Dim AnnEnCours: AnnEnCours = Year(DatePremierJour)
 
If Weekday(DatePremierJour) <> NumJourRechercher Then
        'premiére boucle pour trouver le premier mardi suivant la date du jour
        For T=1 To 6
                If Weekday(DateAdd("d", 1, DatePremierJour+T)) = NumJourRechercher Then
                        'DatePremierJour+T est un mardi, retient la date
                        Redim TblDateRechercher(1)'agrandi la variable tableau en conservant les données des indices déjà existants
                        TblDateRechercher(0)= FormatDateTime(DateAdd("d", 1, DatePremierJour+T),2)
                        Exit For ' sortie de la boucle
                End If
        Next
        Else
        'la date du premier jour est un mardi, retient la date
        TblDateRechercher(0)= DateAdd("d", 1, DatePremierJour)
End If
 
'boucle sur le restant de l'année en cours
Dim DateBoucle2: DateBoucle2 = Cdate(TblDateRechercher(0))+7
Dim DatePlus1An: DatePlus1An = Cdate(FormatDateTime(DateAdd("yyyy",1,DatePremierJour),2))
'msgbox DatePlus1An
For T = DateBoucle2 To DatePlus1An step 7
        'msgbox Ubound(TblDateRechercher)
        Redim Preserve TblDateRechercher(Ubound(TblDateRechercher)+1)
        'msgbox Ubound(TblDateRechercher)
        TblDateRechercher(Ubound(TblDateRechercher)-1)=T
Next
'TblDateRechercher contient maintenant la totalitée des dates recherchées, correspondant au nom du jour de la semaine
 
'Vérification
msgbox "il y a " & Ubound(TblDateRechercher) & " mardi(s) d'ici la fin de l'année"
Dim U: U=Ubound(TblDateRechercher)
For T = 0 to Ubound(TblDateRechercher)-1
        msgbox TblDateRechercher(t)& " date " & (T+1) & " sur " & U
Next