'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 21/03/2008
' Sujet : mDF MFCmultiples v5.0
'---------------------------------------------------------------------------------------
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim FCible As Range, RCible As Range, Cible As Range, Plage As Range, T As Range, _
Tplage As Range, PlageFC As Range
Dim Adr As String
Dim N As Boolean, B As Boolean, P As Boolean, A As Boolean, VFC As Boolean
On Error Resume Next
Set PlageFC = Sh.Cells.SpecialCells(xlCellTypeAllFormatConditions)
If PlageFC Is Nothing Then Exit Sub
'Définition de la Plage cible
Set Plage = Target
Set Tplage = Plage.Dependents
Set Plage = Application.Union(Plage, Tplage)
On Error GoTo 0
Set Plage = Application.Intersect(Plage, PlageFC)
If Plage Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set Tplage = Nothing
For Each T In Plage
VFC = VerifFCond(T)
If VFC Then
If Tplage Is Nothing Then
Set Tplage = T
Else
Set Tplage = Union(Tplage, T)
End If
End If
Next T
'Traitement de la plage Cible
If Not Tplage Is Nothing Then
With ActiveWorkbook.Styles("Normal")
N = .IncludeNumber
B = .IncludeBorder
P = .IncludeProtection
A = .IncludeAlignment
.IncludeNumber = False
.IncludeBorder = False
.IncludeProtection = False
.IncludeAlignment = False
End With
For Each Cible In Tplage
Set FCible = FormatCible(Cible)
Set RCible = Nothing
On Error Resume Next
With Cible
Adr = Mid(.ID, 3)
Select Case Adr
Case "Cel"
Set RCible = Cible
Case "Lig"
Set RCible = Application.Intersect(.EntireRow, ActiveSheet.UsedRange)
Case Else
Adr = Replace(Adr, ";", ",")
If Val(Replace(Adr, "$", "")) > 0 Then
Set RCible = Application.Intersect(.EntireColumn, Range(Adr))
Else
Set RCible = Application.Intersect(.EntireRow, Range(Adr))
End If
End Select
End With
On Error GoTo 0
If Not RCible Is Nothing Then
With RCible
If FCible.Row = 65536 Then
'Format standard
.Style = "Normal"
Else
'Format MFC
With .Font
.Bold = FCible.Font.Bold
.Color = FCible.Font.Color
.Italic = FCible.Font.Italic
.Name = FCible.Font.Name
.Size = FCible.Font.Size
.Strikethrough = FCible.Font.Strikethrough
.Subscript = FCible.Font.Subscript
.Superscript = FCible.Font.Superscript
.Underline = FCible.Font.Underline
End With
With .Interior
.Color = FCible.Interior.Color
.Pattern = FCible.Interior.Pattern
.PatternColor = FCible.Interior.PatternColor
End With
End If
End With
End If
Next Cible
With ActiveWorkbook.Styles("Normal")
.IncludeNumber = N
.IncludeBorder = B
.IncludeProtection = P
.IncludeAlignment = A
End With
End If
Application.ScreenUpdating = True
End Sub
Private Function VerifFCond(C As Range) As Boolean
Dim FCF As String, Op As String
On Error Resume Next
With C.FormatConditions(1)
FCF = .Formula1
Op = CStr(.Operator)
End With
On Error GoTo 0
Select Case Val(Op)
Case 3, 5 To 8
Op = Op & "|"
Case Else
Exit Function
End Select
VerifFCond = True
Select Case Left(FCF, 5)
Case "=mDF"
C.ID = Op & "Cel"
Case "=mDF("
If FCF = "=mDF()" Then
C.ID = Op & "Lig"
Else
C.ID = Op & Replace(Replace(FCF, ")", ""), "=mDF(", "")
End If
Case Else
C.ID = ""
VerifFCond = False
End Select
End Function
Private Function FormatCible(Cible As Range) As Range
Dim C As Range
Dim L As Variant, Veg As Variant, Veginf As Variant
With Sheets("MFC")
If Not IsEmpty(Cible) Then
If Not (Val(Cible.ID) > 3 And Not IsNumeric(Cible.Value)) Then
Veg = Application.Match(Cible.Value, .Columns(1), 0)
Veginf = Application.Match(Cible.Value, .Columns(1), 1)
Select Case Val(Cible.ID)
Case 3 '=
L = IIf(IsError(Veg), 0, Veg)
Case 5 '>
L = IIf(IsError(Veginf), 0, Veginf) - 1
Case 6 '<
L = Application.Max(IIf(IsError(Veginf), 0, Veginf) + 1, 2)
Case 7 '>=
L = IIf(IsError(Veg), 0, Veg)
If L = 0 Then
L = IIf(IsError(Veginf), 0, Veginf)
End If
Case 8 '<=
L = IIf(IsError(Veg), 0, Veg)
If L = 0 Then
L = Application.Max(IIf(IsError(Veginf), 0, Veginf) + 1, 2)
End If
End Select
If L > 1 Then
Set C = .Cells(L, 1)
End If
End If
End If
If C Is Nothing Then Set C = .Cells(65536, 1)
End With
Set FormatCible = C
End Function
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
'Trie automatiquement les critères de l'onglet MFC
If Sh.Name = "MFC" Then
Application.ScreenUpdating = False
With Sh
.Columns(1).Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Application.ScreenUpdating = True
End If
End Sub
