Titre du sujet : Re: mDF MFCmultiples v5.1 - copier les bordures aussi
par myDearFriend! le 29/07/2010 22:30:27
Bonsoir jogig et bienvenue sur XLpages.com 
Curieusement, une des premières versions de cette macro incluait également la prise en compte des bordures. De mémoire, j'en avais supprimé la gestion sur demande d'un utilisateur à l'époque... comme quoi, chacun a ses préférences.
Pour rétablir la prise en compte des bordures, il te faut :
- d'une part, définir les bordures dans l'onglet MFC (c'est à dire inclure les valeurs, leur format cible ainsi que les bordures souhaitées).
- Puis, en te basant toujours sur le code proposé dans le fichier Exemple en Téléchargement, dans le code VBA de l'objet ThisWorkbook, tu dois remplacer la procédure Workbook_SheetChange (et seulement celle-ci), par :
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, 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
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
Pour info, pour obtenir cette nouvelle procédure, j'ai supprimé toute notion de ".IncludeBorder" et j'ai ajouté les 5 lignes suivantes :
With .Borders
.Color = FCible.Borders.Color
.LineStyle = FCible.Borders.LineStyle
.Weight = FCible.Borders.Weight
End With
En espérant que ça puisse répondre à ton besoin.
Cordialement,
|
Didier FOURGEOT