Forums XLPages

Excel & VBA Forum principal [résolu] mDF MFCmultiples v5.1 - copier les bordures aussi

mDF MFCmultiples v5.1 - copier les bordures aussi
#1
jogig
Débutant XLPages

Inscription: 29/07/2010

Messages: 5

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 29-07-2010 21h06

Bonjour tout le monde,

J'utilise le code MFCmultiples v5.1 que j'ai trouvé sur ce site, mais il me semble que ce code ne fonctionne pas avec les bordures...

Est-ce qu'il y aurait un moyen pour que le formattage condionnel considère aussi les bordures (c'est surtout les 2 diagonales qui m'intéressent)?

Merci d'avance!
Hors Ligne
 Rapport   Haut 

Re: mDF MFCmultiples v5.1 - copier les bordures aussi
#2
myDearFriend!
Webmestre

Inscription: 18/05/2006
De Saône-et-Loire (71)

Messages: 1539

Système d'exploitation:
PC
Version Excel utilisée:
97, 2000, 2002, 2003, 2007, 2010, 2013, 2016 et 365
Posté le : 29-07-2010 22h30
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_mDF
Image redimensionnée
Le Webmaster

La réponse vous satisfait ? Merci de revenir solder le sujet en [résolu], voir ce lien
Hors Ligne
 Rapport   Haut 

Re: mDF MFCmultiples v5.1 - copier les bordures aussi
#3
jogig
Débutant XLPages

Inscription: 29/07/2010

Messages: 5

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 29-07-2010 22h50

C'est exactement ce que je cherchais!

Merci pour ton aide et ta réponse rapide :)
Hors Ligne
 Rapport   Haut 

Re: mDF MFCmultiples v5.1 - copier les bordures aussi
#4
jogig
Débutant XLPages

Inscription: 29/07/2010

Messages: 5

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 30-07-2010 15h25

Bonjour,

La solution que vous avez proposée fonctionne effectivement pour les bordures autour de la cellule, mais ça ne semble pas fonctionner pour les diagonales...est-ce qu'il y aurait moyen d'inclure les diagonales aussi?

Merci!
Hors Ligne
 Rapport   Haut 

mDF MFCmultiples v5.1 - copier les bordures aussi (suite)
#5
jogig
Débutant XLPages

Inscription: 29/07/2010

Messages: 5

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 30-07-2010 16h43


Bonjour,

Une partie de ce problème avait été résolue dans une autre discussion, mais j'aimerais savoir s'il est possible d'inclure également les bordures diagonales dans le MFCmultiples v5.1?

La solution proposée par Didier permet de considérer les bordures autour de la cellule, mais la méthode ne semble pas fonctionner pour les bordures diagonales. 

Voici le code proprosé par Didier pour inclure les bordures autour de la cellule:

With .Borders
        .Color = FCible.Borders.Color
        .LineStyle = FCible.Borders.LineStyle
        .Weight = FCible.Borders.Weight
End With


Comment faire pour inclure les diagonales aussi?

Merci!
Hors Ligne
 Rapport   Haut 

Re: mDF MFCmultiples v5.1 - copier les bordures aussi (suite)
#6
myDearFriend!
Webmestre

Inscription: 18/05/2006
De Saône-et-Loire (71)

Messages: 1539

Système d'exploitation:
PC
Version Excel utilisée:
97, 2000, 2002, 2003, 2007, 2010, 2013, 2016 et 365
Posté le : 30-07-2010 21h49
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_mDF
Image redimensionnée
Le Webmaster

La réponse vous satisfait ? Merci de revenir solder le sujet en [résolu], voir ce lien
Hors Ligne
 Rapport   Haut 

Re: mDF MFCmultiples v5.1 - copier les bordures aussi (suite)
#7
jogig
Débutant XLPages

Inscription: 29/07/2010

Messages: 5

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 31-07-2010 13h48

Cette fois ça fonctionne parfaitement!

Il me met des bordures diagonales noires par défaut même si je n'en avais pas mis dans les cellules "références" de la feuille MFC, mais je contourne le problème en mettant des diagonales de la même couleur que le fond de la cellule lorsque je ne désire pas avoir de diagonale.

Merci encore une fois! :)
Hors Ligne
 Rapport   Haut 


Vous pouvez voir les sujets.
Vous ne pouvez pas débuter de nouveaux sujets.
Vous ne pouvez pas répondre aux contributions.
Vous ne pouvez pas éditer vos contributions.
Vous ne pouvez pas effacez vos contributions.
Vous ne pouvez pas ajouter de nouveaux sondages.
Vous ne pouvez pas voter en sondage.
Vous ne pouvez pas attacher des fichiers à vos contributions.
Vous ne pouvez pas poster sans approbation.

[Recherche avancée]


Qui consulte actuellement ce sujet ?   1 Utilisateur(s) anonymes