Sub Stat_Mensuelles()
Dim WSh As Worksheet, Wsh_Stat_Mensuelles As Worksheet, i As Byte, j As Byte, Tb_Mois_Disp()
'Recherche de la feuille de stat mensuelles
Set Wsh_Stat_Mensuelles = Nothing
On Error Resume Next
Set Wsh_Stat_Mensuelles = ThisWorkbook.Worksheets(Sh_Stat_Mensuelles)
On Error GoTo 0
If Wsh_Stat_Mensuelles Is Nothing Then
MsgBox "On ne trouve pas la feuille de statistiques mensuelles !"
Exit Sub 'Sortie si echec
End If
Wsh_Stat_Mensuelles.Protect UserInterfaceOnly:=True
'Recherche de Feuilles 'Semaine_x'
i = 0
For Each WSh In ThisWorkbook.Worksheets
If WSh.Name Like "Semaine_*" Then
i = i + 1
ReDim Preserve TBS(1 To i): ReDim Preserve TBA(1 To i): ReDim Preserve TBD(1 To i): ReDim Preserve TBF(1 To i)
TBS(i) = CByte(Replace(WSh.Name, "Semaine_", "")) 'liste des N° de semaine disponibles
TBA(i) = WSh.Range(Adr_N°_An).Value 'liste des années pour ces semaine (pour cas 1er janvier)
TBD(i) = CLng(Lundi_An_Semaine(CDate(TBA(i)), CByte(TBS(i)))) 'liste des débuts de semaine (date des lundis en long)
TBF(i) = TBD(i) + 6 'liste des fins de semaine (date des dimanches en long)
End If
Next
If i = 0 Then
MsgBox "Aucune statistisque hebdomadaire enregistrée !"
Exit Sub 'Sortie si echec
End If
With WorksheetFunction
Année = .Max(TBA) 'année en cours
Premier_J = CDate(.Min(TBD))
Dernier_J = CDate(.Max(TBF))
'Mois disponible pour l'enregistrement
Tb_Mois = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", "Juillet", "Aoüt", "Septembre", "Octobre", "Novembre", "Décembre")
j = 0
For i = 1 To 12
If DateSerial(Année, i, 1) >= Premier_J And .EoMonth(DateSerial(Année, i, 1), 0) <= Dernier_J Then
j = j + 1
ReDim Preserve Tb_Mois_Disp(1 To j)
Tb_Mois_Disp(j) = Tb_Mois(i - 1)
End If
Next i
End With
If j = 0 Then
MsgBox "Pas assez de statistiques hebdomadaire pour enregistrer un mois !"
Exit Sub 'Sortie si aucun mois complet
End If
Tb_Mois = Tb_Mois_Disp 'Tb_Mois ne contient que les mois disponibles
'Affichage du formulaire de sélection du mois à enregistrer
With UsF_Mensuelles
SDéb = -1: SFin = -1
.CbB_Liste_Mois.List = Tb_Mois
.Show
End With
Unload UsF_Mensuelles
If SDéb = -1 And SFin = -1 Then Exit Sub 'Sortie si aucune période choisie
ReDim Tb_Stat_S(1 To Nb_Lgn_Stat, 1 To 1)
ReDim Tb_Stat_Mois(1 To UBound(Tb_Stat_S, 1), 1 To 1)
'Cas de la 1ère semaine :
JS = Weekday(DateSerial(Année, Mois_Choisi, 1), vbMonday)
If JS > 1 Then
If Not FeuilleExiste("Semaine_" & SDéb) Then
MsgBox "Il manque l'enregistrement de la semaine " & SDéb
Exit Sub
End If
'Si le jour de début de mois n'est pas un Lundi
'Ne prendre que les jours du mois
Set WSh = ThisWorkbook.Worksheets("Semaine_" & SDéb)
WSh.Protect UserInterfaceOnly:=True
With WSh.Evaluate(Plg_Données)
'on mémorise toutes les donnée de la semaine
Tb_Svg = .Value
'on efface les données de l'année antérieure
.Columns(1).Resize(, JS - 1).ClearContents
'on mémorise la colonne Total
Tb_Stat_S = .Columns(8).Value
'On ajoute les valeurs au tableau de stat mensuelles
For i = 1 To Nb_Lgn_Stat
Tb_Stat_Mois(i, 1) = Tb_Stat_Mois(i, 1) + Tb_Stat_S(i, 1)
Next i
'On retablit les données effacées
.Value = Tb_Svg
End With
'Pour la boucle sur les semaines complètes on incrémente Sdéb de 1
SDéb = SDéb + 1
End If
'Cas de la dernière semaine
JF = Weekday(WorksheetFunction.EoMonth(DateSerial(Année, Mois_Choisi, 1), 0), vbMonday)
If JF < 7 Then
If Not FeuilleExiste("Semaine_" & SFin) Then
MsgBox "Il manque l'enregistrement de la semaine " & SFin
Exit Sub
End If
'Si le jour de fin de mois n'est pas un dimanche
'Ne prendre que les jours du mois
Set WSh = ThisWorkbook.Worksheets("Semaine_" & SFin)
WSh.Protect UserInterfaceOnly:=True
With WSh.Evaluate(Plg_Données)
'on mémorise toutes les donnée de la semaine
Tb_Svg = .Value
'on efface les données du mois suivant
.Columns(1).Offset(, JF).Resize(, 7 - JF).ClearContents
'on mémorise la colonne Total
Tb_Stat_S = .Columns(8).Value
'On ajoute les valeurs au tableau de stat mensuelles
For i = 1 To Nb_Lgn_Stat
Tb_Stat_Mois(i, 1) = Tb_Stat_Mois(i, 1) + Tb_Stat_S(i, 1)
Next i
.Value = Tb_Svg
End With
'Pour la boucle sur les semaines complètes on décrémente SFin de 1
SFin = SFin - 1
End If
'Boucle sur les semaines complètes
For i = SDéb To SFin
If Not FeuilleExiste("Semaine_" & i) Then
MsgBox "Il manque l'enregistrement de la semaine " & i
Exit Sub
End If
Set WSh = ThisWorkbook.Worksheets("Semaine_" & i)
With WSh
'on mémorise la colonne Total
Tb_Stat_S = .Evaluate(Plg_Données).Columns(8).Value
'On ajoute les valeurs au tableau de stat mensuelles
For j = 1 To Nb_Lgn_Stat
Tb_Stat_Mois(j, 1) = Tb_Stat_Mois(j, 1) + Tb_Stat_S(j, 1)
Next j
End With
Next i
With Wsh_Stat_Mensuelles.Evaluate(Plg_Stat_Mensuelles)
.Columns(Mois_Choisi).Value = Tb_Stat_Mois
End With
End Sub