Microsoft 365 Bordure impression

clairmrs · 3 Décembre 2020

Bonjour à tous,

Je vous contacte aujourd'hui car j'ai crée une macro sous excel qui me permet de mettre en page rapidement mes documents. Des bordures se dessinent sur les extrémités du tableau mais elle descendent jusqu'en bas de la feuille. Cela ne me pose pas de problème car mon fichier est destiné à l'impression. Je rencontre un problème avec ma zone d'impression, car il reste des bordures verticales en bas du tableau que ne dois supprimer manuellement. J'ai donc essayé de redéfinir ma zone d'impression une ligne au dessus mais du coup ma dernière bordure horizontale n’apparaît pas. Ci joint des annexes avec les bordures en jaunes à supprimer. Quelqu'un à une solution à ce problème ?
Je vous remercie de votre aide.
Dans l'attente de vous lire

Staple1600 · 5 Décembre 2020

Bonjour clairems, le fil, le forum

Je te laisse tester sur ton fichier

VB:

Sub Test()
Dim rng As Range
Set rng = Range(ActiveSheet.PageSetup.PrintArea)
'
'-> ton code VBA d'origine pour les  bordures
'(moins le code qui bordure le contour de ton tableau
'
'bordurage du Contour
rng.BorderAround 1, xlMedium
End Sub

clairmrs · 11 Décembre 2020

Staple1600 à dit:

Bonjour clairems, le fil, le forum

VB:

Sub CLAIRE()

'Mettre en page les en-tête et pied de page
With ActiveSheet.PageSetup
    'en-tête de page
    .LeftHeader = Range("B1").Value & Chr(10) & "Décomposition du Prix Global et Forfaitaire" 'Nom de l'affaire + saut de ligne + DPGF
    .RightHeader = "&A" & Chr(10) & "Page " & "&P/&N" 'Numéro et nom de lot + saut de ligne + numéro de page/ nbr de page
    ' pied de page
    .CenterFooter = "Etabli par ESPINAL INGENIERIE, le " & "&D" & Chr(10) & "Phase DCE - Indice A"  ' Auteur + date + saute de ligne + phase
End With

'Supprimer la ligne 1
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
    
'Supprimer la ligne 3
    Rows("3:3").Select
    Selection.Delete Shift:=xlUp
    
'Remplacer le texte de la cellule B3 par D.P.G.F
Range("B3").Value = "D.P.G.F"
Range("B3").Font.Size = 12

'Supprimer la ligne 4
    Rows("4:4").Select
    Selection.Delete Shift:=xlUp
    
' Insérer deux lignes
    Rows("4:4").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Rows("6:6").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

'Agrandir taille colonne
    Columns("A:A").ColumnWidth = 12.35
    Columns("B:B").ColumnWidth = 65.43
    Columns("C:C").ColumnWidth = 5.71
    Columns("D:D").ColumnWidth = 12.57
    Columns("E:E").ColumnWidth = 10.57
    Columns("F:F").ColumnWidth = 14.14
    
    
'Agrandir taille première ligne
    Rows("1:1").RowHeight = 39
    
Columns("A:A").Select
    Selection.ColumnWidth = 12.7
    
'Ajouter "Référence" et "désignation" dans les colonnes A et B
ActiveCell.FormulaR1C1 = "Référence"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Désignation"
    Range("A1").Select
    
  
'Centrer les titres au milieu de la case
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("B1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("C1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("D1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("E1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("F1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
'Rajouter bordure colonne A
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone

'Passer les colonnes C,D,E et F en taille 8 et police Arial
Range("C:F").Font.Size = 8
Range("C:F").Font.Name = "Arial"


'Passer la ligne 1 en taille 10, Arial
Rows("1").Font.Size = 10
Rows("1").Font.Name = "Arial"


' Mettre tout ce qui est en calibri, gras taille 11 --> en arial, gras taille 12
     With Application.FindFormat.Font
        .Name = "Calibri"
        .FontStyle = "Gras"
        .Size = 11
        .Superscript = False
        .Subscript = False
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With Application.ReplaceFormat.Font
        .Name = "Arial"
        .FontStyle = "Gras"
        .Size = 12
        .Subscript = False
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
    Cells.Replace What:="", Replacement:="", LookAt:=xlWhole, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
    
'Chercher la dernière ligne du tableau
    Cells.Find(What:="Montant TTC", After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Select
    ActiveCell.RowHeight = 25
    
 'Remplacer par "T.V.A au taux de 20,00%" en Arial taille 12, gras
ActiveCell.Offset(-1, 0).Select
    ActiveCell.FormulaR1C1 = "T.V.A au taux de 20,00%"
    
'Modifier formule TVA + rajouter bordure
    ActiveCell.Offset(0, 4).Select
    With Selection
             .FormulaR1C1 = "=(R[-1]C*20)/100"
             .Borders(xlEdgeBottom).Weight = xlMedium   ' bordure bass
End With

'Dessiner bordure bas du tableau
ActiveCell.Offset(2, 0).Select
    With Selection
        .Borders(xlEdgeTop).Weight = xlMedium   ' bordure haute
End With

ActiveCell.Offset(0, -1).Select
With Selection
        .Borders(xlEdgeTop).Weight = xlMedium   'bordure haute
End With

ActiveCell.Offset(0, -1).Select
With Selection
        .Borders(xlEdgeTop).Weight = xlMedium   'bordure haute
End With

ActiveCell.Offset(0, -1).Select
With Selection
        .Borders(xlEdgeTop).Weight = xlMedium  'bordure haute
End With

ActiveCell.Offset(0, -1).Select
With Selection
        .Borders(xlEdgeTop).Weight = xlMedium 'bordure haute
End With

ActiveCell.Offset(0, -1).Select
With Selection
        .Borders(xlEdgeTop).Weight = xlMedium   'bordure haute
End With


'Dessiner une bordure sous les titres
    Range("A1:F1").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = -16777216
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = -16777216
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = -16777216
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    
'Bordure colonnes A et F
    Columns("F:F").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    
    Columns("A:A").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
      
'Chercher la ligne "Total descriptopn et localisation des ouvrages
    Cells.Find(What:="Montant TTC", After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(-6, 0).Select
        ActiveCell.FormulaR1C1 = "Total D.P.G.F"

End Sub

Je te laisse tester sur ton fichier

VB:

Sub Test()
Dim rng As Range
Set rng = Range(ActiveSheet.PageSetup.PrintArea)
'
'-> ton code VBA d'origine pour les  bordures
'(moins le code qui bordure le contour de ton tableau
'
'bordurage du Contour
rng.BorderAround 1, xlMedium
End Sub

Bonjour,
Je vous remercie d'avoir pris le temps de me répondre et d'avoir cherché une solution à mon problème.
En revanche, je ne comprends pas votre code ??? Veuillez m'excuser...
Je me permets de vous transmettre les fichiers dont je parle (code VBA et fichier excel sur laquelle la macro doit s'appliquer)
Bonne journée
Cordialement

Staple1600 · 11 Décembre 2020

Bonsoir

Est-ce que tu as cherché à testé mon code?
Il est simple à mettre en oeuvre, il suffit de lire les commentaires en vert.
NB: Il faut qu'une zone d'impression ait été définie pour cela fonctionne correctement.

clairmrs · 14 Décembre 2020

Staple1600 à dit:
Bonsoir

Est-ce que tu as cherché à testé mon code?
Il est simple à mettre en oeuvre, il suffit de lire les commentaires en vert.
NB: Il faut qu'une zone d'impression ait été définie pour cela fonctionne correctement.

C'est génial merci beaucoup ! Je n'ai plus ses bordures qu'il fallait gommer à chaque fois, ducoup il faut définir la zone d'impression sur chaque document ou je peux également automatiser cela ?
Cdt

Staple1600 · 14 Décembre 2020

Bonsoir le fil

=>clairms
On peut automatiser, oui.
Joins un fichier exemple (anonymisé) ou donne plus de détails et explications dans ton prochain message.

clairmrs · 15 Décembre 2020

Je parlais de la zone d'impression à définir avant de lancer votre code, je ne sais pas si c'est clair. Car pour faire fonctionner ce que vous m'avez envoyer je dois d’abord définir manuellement la zone d'impression et ensuite lancer la macro
Cdt

Staple1600 · 15 Décembre 2020

Bonsoir

Bah définis ta zone d'impression par macro.
(Et pour ce faire utilise l'enregistreur de macros )

VB:

Sub Exemple()
Dim S1600 As Range 'pour test
Set S1600 = Range("A1:C21") 'pour test
S1600 = "=ADDRESS(ROW(),COLUMN(),4)" 'pour test
ActiveSheet.PageSetup.PrintArea = S1600.Address ' la ligne à  retenir
ActiveSheet.PrintPreview 'pour test
End Sub

Microsoft 365 Bordure impression

clairmrs

XLDnaute Nouveau

Pièces jointes

Staple1600

XLDnaute Barbatruc

clairmrs

XLDnaute Nouveau

Pièces jointes

Staple1600

XLDnaute Barbatruc

clairmrs

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

clairmrs

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Discussions similaires