Discussion :

[vba_lieb]

Bonjour à tous,

Je cherche a créer en VBA un tableau automatique qui me ferait un récapitulatif du nombre de cellule pour chaque mois de l'année inscrit dans cette cellule.
Exemple : compter le nombre de cellule du mois de janvier 2024 et mettre le nombre à à coté de la cellule JANVIER (voir Excel)

Et ainsi de suite pour tous les mois des années existants dans mon fichier.

Je vous mets en exemple le fichier que j'ai préparer pour le test.

L'idée c'est que cela me créer un récapitulatif automatiquement.
Espérant avoir été assez compréhensible


EXCEL_DATE_COMPTER.xlsx

Merci pour votre aide

Lieb

[78chris]

Bonjour

quel est l'intérêt de coder alors qu'un TCD fait cela en quelques clics ?

[vba_lieb]

Je clotrure car j'ai trouvé une solution de contournement

[Nain porte koi]

@Lieb, l'intérêt d'un forum c'est le partage, donc si vous avez une solution ça serait sympa de la mettre à disposition, merci.

[vba_lieb]

@Lieb, l'intérêt d'un forum c'est le partage, donc si vous avez une solution ça serait sympa de la mettre à disposition, merci.

Oups effectivement,
Alors script à customiser pour indiquer le chemin de votre fichier à scanner + la colonne à customiser

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
'Attention les deux lignes suivantes doivent être impérativement placées en tout début de programme
Option Explicit  'Activation de la déclaration explicite des variables
Public WbArchive As Workbook
Public WcArchive As Worksheet
 
Sub BILAN_OF_SEMAINE()
 
'On cache les classeurs qui vont s'ouvrir pour éviter les sauts d'écran
'ATTENTION, NE PAS OUBLIER DE METTRE A TRUE EN FIN DE SCRIPT
Application.ScreenUpdating = False
 
 
'--------- DECLARATION EMPLACEMENT FICHIER : Nom_Fichier.xlsx ---------
'On déclare le fichier source de donnée ARCHIVES
Dim FILE_ARCHIVES As String
FILE_ARCHIVES = "I:\mettre_ici_chemin\Nom_Fichier.xlsx"
 
'On déclare la variable qui contiendra la référence du fichier 
'On ouvre le fichier Archives
Set WbArchive = Workbooks.Open(FILE_ARCHIVES)
 
'On déclare la feuille source dans le fichier Nom_Fichier.xlsx
Set WcArchive = WbArchive.Worksheets("ARCHIVES_FEUILLE")
 
' --- CALCUL DES OF RECUS CETTE SEMAINE ---
'Colonne date de réception : B
    Dim i As Long
    Dim Cnt As Long
    Dim iDay As String
    Dim iSemaine As String
    Dim iMois As String
    Dim iAnnee As String
    Dim noSemaine As String
    Dim nbLignes As Long
 
    'Variable pour recherche NB de cellule avec semaine en cours
    Dim Date_Cel As String
    Dim Semaine_Cel As String
 
    'Variable pour recherche NB de cellule avec le mois en cours
    Dim Month_Find As String
 
 
    'On parametre nos variables
    nbLignes = WcArchive.Cells(Rows.Count, "B").End(xlUp).Row
    iDay = Date
    iSemaine = DatePart("ww", iDay, vbMonday, vbFirstFourDays)
    iMois = Month(Date)
    iAnnee = Year(Date)
    'MsgBox ("La date d'aujourd'hui est : " & iDay)
    'MsgBox ("La semaine en cours est : " & iSemaine)
    'MsgBox ("Le mois en cours est : " & iMois)
    'MsgBox ("L'année en cours est : " & iAnnee)
    'MsgBox ("L'année en cours est : " & iMois & "/" & iAnnee)
 
'On recherche le nombre de cellule ANNEE EN COURS
    nbLignes = WcArchive.Cells(Rows.Count, "B").End(xlUp).Row
 
    'Ici on défini à partir de quelle ligne on doit chercher (Ici c'est la ligne 3)
    For i = 3 To nbLignes
        'If IsDate(Range("B" & I)) Then
                If Format(WcArchive.Range("B" & i).value, "YYYY") = iAnnee Then
                Cnt = Cnt + 1
                End If
            'End If
        Next
'On ecrit les résultats dans le DASHBOARD
    'MsgBox ("On écrit le résultat ANNEE dans le Dashboard : " & Cnt)
    ThisWorkbook.Worksheets("DASHBORD").Range("E10") = Cnt
'On remet à zéro le compteur
Cnt = 0
 
'On recherche le nombre de cellule MOIS EN COURS
    'Je commence ma recherche à la ligne 3
    For i = 3 To nbLignes
                'Je mets dans une variable mois et année de la cellule colonne B
                Month_Find = Format(WcArchive.Range("B" & i).value, "MM/YYYY")
                'MsgBox Month_Find
 
                'Puis si il y a un zero, alors je supprime celui-ci (exemple pour 01 qui est Janvier)
                'Car iDay n'a pas le zero
                If Left(Month_Find, 1) = "0" Then Month_Find = Right(Month_Find, Len(Month_Find) - 1)
 
                'Et maintenant vérification si mois et l'année correspond au mois et l'année de ce jour
                'Et si oui, je rajoute 1 à ma variable Cnt
                If Month_Find = iMois & "/" & iAnnee Then
                Cnt = Cnt + 1
                End If
    Next
'On ecrit les résultats dans le DASHBOARD
    'MsgBox ("On écrit le résultat Mois dans le Dashboard : " & Cnt)
    ThisWorkbook.Worksheets("DASHBORD").Range("E8") = Cnt
'On remet à zéro le compteur
Cnt = 0
 
 
'On recherche le nombre de cellule de cette semaine
    'Je commence ma recherche à la ligne 3
    For i = 3 To nbLignes
        Date_Cel = Format(WcArchive.Range("B" & i).value, "dd/mm/yyyy")
        Semaine_Cel = DatePart("ww", Date_Cel, vbMonday, vbFirstFourDays)
        'MsgBox ("La semaine en cours est : " & iSemaine)
        'MsgBox ("La date de la cellule est : " & Date_Cel)
        'MsgBox ("La semaine de la cellule est : " & Semaine_Cel)
            If Semaine_Cel = iSemaine Then
            Cnt = Cnt + 1
            End If
    Next
'On ecrit les résultats dans le DASHBOARD
    'MsgBox ("On écrit le résultat SEMAINE dans le Dashboard : " & Cnt)
    ThisWorkbook.Worksheets("DASHBORD").Range("E6") = Cnt
'On remet à zéro le compteur
Cnt = 0
 
' --- FIN CALCUL DES OF RECUS SEMAINE / MOIS / ANNEE ---
 
'On ferme fichier archives SANS enregistrement
WbArchive.Close SaveChanges:=False
 
'On dé-cache les classeurs nécéssaires ouvert
'ATTENTION, NE PAS OUBLIER DE METTRE A TRUE EN FIN DE SCRIPT
Application.ScreenUpdating = True
 
End Sub