bonjour le forum
j'ai un programme vba qui me permet d'associer une couleur pour chaque lettre, tout ceci marche tres bien.
mais voila que je protège ma feuille, ca ne marche plus... j'ai essayé de verrouillé et dévérouillé les cellules concerné mais toujours rien.
pouvez vous s'il vous plait m'indiquer la procedure, je vous joint mon vba :
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
Dim N As Boolean, B As Boolean, P As Boolean
On Error Resume Next
Set Plage = Sh.Cells.SpecialCells(xlCellTypeAllFormatConditions)
On Error GoTo 0
If Plage Is Nothing Then Exit Sub
With ActiveWorkbook.Styles("Normal")
N = .IncludeNumber
B = .IncludeBorder
P = .IncludeProtection
End With
For Each T In Target
'Détermine plage cible (Dépendents de T)
Set Plage = PlageCible(T)
If Plage Is Nothing Then Exit Sub
'Traitement de la plage Cible
For Each Cible In Plage
Set FCible = FormatCible(Cible)
If Cible.ID = "L" Then
Set RCible = Application.Intersect(Cible.EntireRow, ActiveSheet.UsedRange)
Else
Set RCible = Cible
End If
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
Next Cible
Next T
With ActiveWorkbook.Styles("Normal")
End With
End Sub
Private Function VerifFCond(C As Range) As Byte
Dim FCF As String
On Error Resume Next
FCF = C.FormatConditions(1).Formula1
On Error GoTo 0
Select Case FCF
Case "=mDF": VerifFCond = 1
Case "=mDFL": VerifFCond = 2
End Select
End Function
Private Function PlageCible(C As Range) As Range
Dim PlageDep As Range, Plage As Range, R As Range
Dim L As Byte
L = VerifFCond(C)
If L Then Set Plage = C
If L = 2 Then C.ID = "L"
On Error Resume Next
Set PlageDep = C.Dependents
On Error GoTo 0
If Not PlageDep Is Nothing Then
For Each R In PlageDep
L = VerifFCond(R)
If L Then
If Plage Is Nothing Then
Set Plage = R
Else
Set Plage = Union(Plage, R)
End If
If L = 2 Then R.ID = "L"
End If
Next R
End If
Set PlageCible = Plage
End Function
Private Function FormatCible(Cible As Range) As Range
Dim C As Range
With Sheets("couleur")
If Not IsEmpty(Cible) Then
If Not IsError(Cible.Value) Then
Set C = .Columns(1).Find(What:=Cible.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
End If
End If
If C Is Nothing Then Set C = .Cells(65536, 1)
End With
Set FormatCible = C
End Function
j'ai un programme vba qui me permet d'associer une couleur pour chaque lettre, tout ceci marche tres bien.
mais voila que je protège ma feuille, ca ne marche plus... j'ai essayé de verrouillé et dévérouillé les cellules concerné mais toujours rien.
pouvez vous s'il vous plait m'indiquer la procedure, je vous joint mon vba :
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
Dim N As Boolean, B As Boolean, P As Boolean
On Error Resume Next
Set Plage = Sh.Cells.SpecialCells(xlCellTypeAllFormatConditions)
On Error GoTo 0
If Plage Is Nothing Then Exit Sub
With ActiveWorkbook.Styles("Normal")
N = .IncludeNumber
B = .IncludeBorder
P = .IncludeProtection
End With
For Each T In Target
'Détermine plage cible (Dépendents de T)
Set Plage = PlageCible(T)
If Plage Is Nothing Then Exit Sub
'Traitement de la plage Cible
For Each Cible In Plage
Set FCible = FormatCible(Cible)
If Cible.ID = "L" Then
Set RCible = Application.Intersect(Cible.EntireRow, ActiveSheet.UsedRange)
Else
Set RCible = Cible
End If
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
Next Cible
Next T
With ActiveWorkbook.Styles("Normal")
End With
End Sub
Private Function VerifFCond(C As Range) As Byte
Dim FCF As String
On Error Resume Next
FCF = C.FormatConditions(1).Formula1
On Error GoTo 0
Select Case FCF
Case "=mDF": VerifFCond = 1
Case "=mDFL": VerifFCond = 2
End Select
End Function
Private Function PlageCible(C As Range) As Range
Dim PlageDep As Range, Plage As Range, R As Range
Dim L As Byte
L = VerifFCond(C)
If L Then Set Plage = C
If L = 2 Then C.ID = "L"
On Error Resume Next
Set PlageDep = C.Dependents
On Error GoTo 0
If Not PlageDep Is Nothing Then
For Each R In PlageDep
L = VerifFCond(R)
If L Then
If Plage Is Nothing Then
Set Plage = R
Else
Set Plage = Union(Plage, R)
End If
If L = 2 Then R.ID = "L"
End If
Next R
End If
Set PlageCible = Plage
End Function
Private Function FormatCible(Cible As Range) As Range
Dim C As Range
With Sheets("couleur")
If Not IsEmpty(Cible) Then
If Not IsError(Cible.Value) Then
Set C = .Columns(1).Find(What:=Cible.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
End If
End If
If C Is Nothing Then Set C = .Cells(65536, 1)
End With
Set FormatCible = C
End Function
