Option Explicit
Private Const MotDePasse = "aaaa"
Private Const ListeMois = "JANVIER,FEVRIER,MARS,AVRIL,MAI,JUIN,JUILLET,AOUT,SEPTEMBRE,OCTOBRE,NOVEMBRE,DECEMBRE,JANVIER N+1"
Sub Effacer()
If MsgBox("Etes-vous sûr de vouloir effacer toutes les données saisies ?", vbYesNo) = vbYes Then
Call EffacerRouge
Call EffacerNoire
MsgBox "Terminé."
Else
MsgBox "Abandon."
End If
End Sub
Sub EffacerRouge()
Dim Cell As Range
Dim NomFeuille As Variant
Dim Feuille As Worksheet
Dim T() As Variant
Dim d As Variant
Dim d1 As Variant
Dim d2 As Variant
Dim i As Integer
Dim j As Integer
Dim ErrNumber As Variant
Dim AppliesToRange As Range
Dim Protection As Boolean
Dim TabMois() As String
Const PremièreCellule = "$R$6"
Const Formule = "=SI(R$1:$CI$1>$D$203;1;SI(R$1:$CI$1<$D$202;1;0))"
TabMois = Split(ListeMois, ",")
For Each NomFeuille In TabMois
On Error Resume Next
Err.Clear
Set Feuille = ThisWorkbook.Worksheets(NomFeuille)
ErrNumber = Err.Number
On Error GoTo 0
'Feuille non trouvée
If ErrNumber Then
MsgBox "La feuille """ & NomFeuille & """ n'existe pas !" & vbCrLf & vbCrLf & _
"Le traitement continue sur les autres feuilles."
'Feuille trouvée
Else
'Feuille protégée
If Feuille.ProtectContents Then
Protection = True
On Error Resume Next
Feuille.Unprotect Password:=MotDePasse
ErrNumber = Err.Number
On Error GoTo 0
Else
Protection = False
End If
'Protection non supprimée
If ErrNumber Then
MsgBox "La feuille """ & NomFeuille & """ n'a pas pu être déprotégée !" & vbCrLf & _
"Déprotéger la feuille ou vérifier le mot de passe dans le code." & vbCrLf & vbCrLf & _
"Le traitement continue sur les autres feuilles."
'Pas de protection ou protection supprimée
Else
'Recherche de la MFC concernée
Set Cell = Feuille.Range(PremièreCellule)
For i = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(i)
If .Type = xlExpression And .Formula1 = Formule Then
Set AppliesToRange = .AppliesTo
Exit For
End If
End With
Next i
'MFC non trouvée
If i > Cell.FormatConditions.Count Then
MsgBox "Sur la feuille """ & NomFeuille & """, la MFC n'a pas été trouvée telle qu'attendue en " & PremièreCellule & _
" pour la formule:" & vbCrLf & _
"Formule: " & Formule & vbCrLf & vbCrLf & _
"Le traitement continue sur les autres feuilles."
'MFC trouvée
Else
'Table aux valeurs de l'AppliesTo Range de la MFC
T = AppliesToRange.Value
'Dates à comparer
d1 = Feuille.Range("$D$203").Value
d2 = Feuille.Range("$D$202").Value
For i = 1 To UBound(T, 1)
For j = 1 To UBound(T, 2)
If T(i, j) = 1 Then
d = Feuille.Cells(1, j + 17).Value
If d > d1 Or d < d2 Then
'MsgBox Cell.Address
T(i, j) = ""
End If
End If
Next j
Next i
'Valeurs de l'AppliesTo Range de la MFC aux valeurs de la table
AppliesToRange.Value = T
'Reset de la protection
If Protection Then Feuille.Protect Password:=MotDePasse
End If
End If
End If
Next NomFeuille
End Sub
Sub EffacerNoire()
Dim Cell As Range
Dim NomFeuille As Variant
Dim Feuille As Worksheet
Dim T() As Variant
Dim d As Variant
Dim Td() As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim ErrNumber As Variant
Dim AppliesToRange As Range
Dim Protection As Boolean
Dim TabMois() As String
Const PremièreCellule = "$R$6"
Const Formule = "=SI(R$1:$CI$1=CALENDRIER!$V$3;1;SI(R$1:$CI$1=CALENDRIER!$V$4;1;SI(R$1:$CI$1=CALENDRIER!$V$5;1;SI(R$1:$CI$1=CALENDRIER!$V$6;1;SI(R$1:$CI$1=CALENDRIER!$V$7;1;SI(R$1:$CI$1=CALENDRIER!$V$8;1;SI(R$1:$CI$1=CALENDRIER!$V$9;1;SI(R$1:$CI$1=CALENDRIER!$V$10;1;SI(R$1:$CI$1=CALENDRIER!$V$11;1;SI(R$1:$CI$1=CALENDRIER!$V$12;1;SI(R$1:$CI$1=CALENDRIER!$V$13;1;SI(R$1:$CI$1=CALENDRIER!$V$14;1;SI(R$1:$CI$1=CALENDRIER!$V$15;1;SI(R$1:$CI$1=CALENDRIER!$V$16;1;0))))))))))))))"
TabMois = Split(ListeMois, ",")
For Each NomFeuille In TabMois
On Error Resume Next
Err.Clear
Set Feuille = ThisWorkbook.Worksheets(NomFeuille)
ErrNumber = Err.Number
On Error GoTo 0
'Feuille non trouvée
If ErrNumber Then
MsgBox "La feuille """ & NomFeuille & """ n'existe pas !" & vbCrLf & vbCrLf & _
"Le traitement continue sur les autres feuilles."
'Feuille trouvée
Else
'Feuille protégée
If Feuille.ProtectContents Then
Protection = True
On Error Resume Next
Feuille.Unprotect Password:=MotDePasse
ErrNumber = Err.Number
On Error GoTo 0
Else
Protection = False
End If
'Protection non supprimée
If ErrNumber Then
MsgBox "La feuille """ & NomFeuille & """ n'a pas pu être déprotégée !" & vbCrLf & _
"Déprotéger la feuille ou vérifier le mot de passe dans le code." & vbCrLf & vbCrLf & _
"Le traitement continue sur les autres feuilles."
'Pas de protection ou protection supprimée
Else
'Recherche de la MFC concernée
Set Cell = Feuille.Range(PremièreCellule)
For i = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(i)
If .Type = xlExpression And .Formula1 = Formule Then
Set AppliesToRange = .AppliesTo
Exit For
End If
End With
Next i
'MFC non trouvée
If i > Cell.FormatConditions.Count Then
MsgBox "Sur la feuille """ & NomFeuille & """, la MFC n'a pas été trouvée telle qu'attendue en " & PremièreCellule & _
" pour la formule:" & vbCrLf & _
"Formule: " & Formule & vbCrLf & vbCrLf & _
"Le traitement continue sur les autres feuilles."
'MFC trouvée
Else
'Table aux valeurs de l'AppliesTo Range de la MFC
T = AppliesToRange.Value
'Dernière ligne colonne V de la feuille CALENDRIER
i = ThisWorkbook.Worksheets("CALENDRIER").Range("V" & Rows.Count).End(xlUp).Row
'Dates à comparer
Td = ThisWorkbook.Worksheets("CALENDRIER").Range("V3:V" & i).Value
For i = 1 To UBound(T, 1)
For j = 1 To UBound(T, 2)
If T(i, j) = 1 Then
d = Feuille.Cells(1, j + 17).Value
For k = 1 To UBound(Td, 1)
If d = Td(k, 1) Then Exit For
Next k
If k <= UBound(Td, 1) Then
'MsgBox Cell.Address
T(i, j) = ""
End If
End If
Next j
Next i
'Valeurs de l'AppliesTo Range de la MFC aux valeurs de la table
AppliesToRange.Value = T
'Reset de la protection
If Protection Then Feuille.Protect Password:=MotDePasse
End If
End If
End If
Next NomFeuille
End Sub