Titre du sujet : Re: mDF MFCmultiples v5.1 - copier les bordures aussi (suite)
par myDearFriend! le 30/07/2010 21:49:01
Bonsoir jogig, le Forum,
Tout d'abord, j'ai fusionné le présent sujet avec le précédent (que je réactive) puisqu'il s'agit toujours du même problème...
Efffectivement, je m'aperçois que tu parlais des diagonales dans ton premier post, je n'avais pas fait attention.
Voici donc un moyen de contourner ce problème (même punition : procédure Workbook_SheetChange à remplacer) :
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 B As Byte
Dim N 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
P = .IncludeProtection
A = .IncludeAlignment
.IncludeNumber = 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
With .Borders
.Color = FCible.Borders.Color
.LineStyle = FCible.Borders.LineStyle
.Weight = FCible.Borders.Weight
For B = 5 To 6
.Item(B).Color = FCible.Borders(B).Color
.Item(B).LineStyle = FCible.Borders(B).LineStyle
.Item(B).Weight = FCible.Borders(B).Weight
Next B
End With
End If
End With
End If
Next Cible
With ActiveWorkbook.Styles("Normal")
.IncludeNumber = N
.IncludeProtection = P
.IncludeAlignment = A
End With
End If
Application.ScreenUpdating = True
End Sub
Cette fois, j'ai ajouté les lignes suivantes :
'
'
Dim B As Byte
'
'
'
'
For B = 5 To 6
.Item(B).Color = FCible.Borders(B).Color
.Item(B).LineStyle = FCible.Borders(B).LineStyle
.Item(B).Weight = FCible.Borders(B).Weight
Next B
'
'
J'ai, bien sûr aussi dans l'idée que cette fois, le code mériterait d'être révisé en profondeur pour optimiser l'ensemble, mais je n'ai malheureusement pas le temps de me pencher là dessus en ce moment. Désolé.
En espérant que ça puisse te dépanner quand même...
Cordialement
|
Didier FOURGEOT