'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!)
' Date : 18/09/2005
' Sujet : MFC multiples
' Modification : Yeahou
' Date : 18/09/2018
' Sujet : application des MFC multiples aux formules
'---------------------------------------------------------------------------------------
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim TabTemp As Variant
Dim L As Long
Dim V As Variant
Dim Cellules_en_MFC As Range, Cellules_en_Formule As Range, Formule_et_MFC As Range, Cellule_en_Cours As Range
'trouve les cellules en MFC de la feuille
Set Cellules_en_MFC = Sh.Cells.SpecialCells(xlCellTypeAllFormatConditions)
'trouve les cellules en formule de la feuille
Set Cellules_en_Formule = Sh.Cells.SpecialCells(xlCellTypeFormulas, 23)
If Not Application.Intersect(Cellules_en_MFC, Cellules_en_Formule) Is Nothing Then
'désactive l'affichage écran
Application.ScreenUpdating = False
'Lance pour chaque cellule trouvée
Set Formule_et_MFC = Application.Intersect(Cellules_en_MFC, Cellules_en_Formule)
For Each Cellule_en_Cours In Formule_et_MFC
'Vérifie la présence du format conditionnel "spécial"
If Cellule_en_Cours.FormatConditions.Count > 0 Then
If Cellule_en_Cours.FormatConditions(1).Formula1 = "=mDF" Then
With Sheets("MFC")
'Charge les préférences dans un tableau variant temporaire
L = .Range("A65536").End(xlUp).Row
TabTemp = .Range(.Cells(1, 1), .Cells(L, 1)).Value
'Détermine le format à utiliser suivant la valeur de la cellule
If Cellule_en_Cours.Value = "" Then
L = 1
Else
For L = 2 To UBound(TabTemp, 1)
'Fonctionne en minuscule/majuscule pour les chaines de caractères
If UCase(Cellule_en_Cours.Value) = UCase(TabTemp(L, 1)) Then Exit For
Next L
End If
'Gestion des erreurs (impératif, compte tenu de la désactivation des évènements)
On Error GoTo Fin
Application.EnableEvents = False
'Applique le format (sauf les bordures)
.Cells(L, 2).Copy
V = Cellule_en_Cours.Formula
Cellule_en_Cours.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Cellule_en_Cours.Formula = V
'Il semble que sur Mac et dans certaines situations (non ciblées) le format
'conditionnel "spécial" d'origine ne soit pas écrasé par le nouveau, il convient
'donc de s'en assurer avant de réimposer ce format spécial.
If Cellule_en_Cours.FormatConditions.Count < 1 Then Cellule_en_Cours.FormatConditions.Add Type:=xlExpression, Formula1:="=mDF"
Application.CutCopyMode = False
Application.EnableEvents = True
End With
End If
End If
Next Cellule_en_Cours
Set Cellules_en_MFC = Nothing
Set Cellules_en_Formule = Nothing
Set Formule_et_MFC = Nothing
Set Cellule_en_Cours = Nothing
'réactive l'affichage écran
Application.ScreenUpdating = True
End If
Exit Sub
Fin:
'En cas d'erreur dans le code, il convient impérativement de rétablir la gestion des
'évènements d'application pour la suite. Par une gestion d'erreur, on réaffecte la
'valeur True à la propriété Application.EnableEvents et on informe l'utilisateur qu'une
'erreur non gérée est survenue
MsgBox "Erreur non gérée dans la procédure Workbook.SheetChange()" & vbLf & "Erreur : " & _
Err & " " & Err.Description, vbOKOnly, "myDearFriend!"
Application.EnableEvents = True
End Sub
