Option Explicit
Sub Effacer1()
Dim Cell As Range
Dim Feuille As Worksheet
Dim i As Integer
Dim AppliesToRange As Range
If MsgBox("Etes-vous sûr de vouloir effacer toutes les données saisies ?", vbYesNo) = vbYes Then
On Error Resume Next
Set Feuille = ActiveSheet
'Recherche de la MFC concernée
Set Cell = Feuille.Cells.Range("$R$6:$CI$90").SpecialCells(xlCellTypeAllFormatConditions).Cells(1, 1)
For i = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(i)
If .Type = xlExpression And .Formula1 = "=SI(R$1:$CI$1>$D$203;1;SI(R$1:$CI$1<$D$202;1;0))" Then
Set AppliesToRange = .AppliesTo
Exit For
End If
End With
Next i
If i > Cell.FormatConditions.Count Then
MsgBox "La MFC n'a pas été trouvée telle qu'attendue:" & vbCrLf & _
"Formule: =SI(R$1:$CI$1>$D$203;1;SI(R$1:$CI$1<$D$202;1;0))"
Exit Sub
End If
For Each Cell In AppliesToRange.Cells
If Cell.Value = 1 Then
If Feuille.Cells(1, Cell.Column) > Feuille.Range("$D$203").Value _
Or Feuille.Cells(1, Cell.Column) < Feuille.Range("$D$202").Value Then
'MsgBox Cell.Address
Cell.Value = 0
End If
End If
Next Cell
End If
End Sub
Sub Effacer2()
Dim Cell As Range
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 AppliesToRange As Range
If MsgBox("Etes-vous sûr de vouloir effacer toutes les données saisies ?", vbYesNo) = vbYes Then
On Error Resume Next
Set Feuille = ActiveSheet
'Recherche de la MFC concernée
Set Cell = Feuille.Cells.Range("$R$6:$CI$90").SpecialCells(xlCellTypeAllFormatConditions).Cells(1, 1)
For i = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(i)
If .Type = xlExpression And .Formula1 = "=SI(R$1:$CI$1>$D$203;1;SI(R$1:$CI$1<$D$202;1;0))" Then
Set AppliesToRange = .AppliesTo
Exit For
End If
End With
Next i
If i > Cell.FormatConditions.Count Then
MsgBox "La MFC n'a pas été trouvée telle qu'attendue:" & vbCrLf & _
"Formule: =SI(R$1:$CI$1>$D$203;1;SI(R$1:$CI$1<$D$202;1;0))"
Exit Sub
End If
T = AppliesToRange.Value
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) = 0
End If
End If
Next j
Next i
AppliesToRange.Value = T
End If
End Sub
