greghennequin
XLDnaute Nouveau
J'ai consulté sur le site plusieurs discussions à ce sujet; chargé un code VBA pour y arriver mais cela ne marche pas si la cellule contient une formule. Quelqu'un a t il une solution? Passer par la touche "précision de l'affichage" mais je perds alors ma formule... concerne la feuille 'quadri1' zone sous J3 AK3 dans le fichier joint.
merci de votre aide
le code est le suivant:
Option Explicit
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - mon Univers Excel... : myDearFriend! Excel Pages
' 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
greghennequin
merci de votre aide
le code est le suivant:
Option Explicit
'---------------------------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - mon Univers Excel... : myDearFriend! Excel Pages
' 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
greghennequin
