Rajouter une bordure noire dans un tableau par VBA

Résolu

Dreampower75 Messages postés 88 Date d'inscription Statut Membre Dernière intervention -
Patrice33740 Messages postés 8561 Date d'inscription Statut Membre Dernière intervention - 7 mai 2022 à 13:31

Bonjour,

J'ai crée une VBA qui crée un tableau dans l'onglet "SYNTHESE" en intégrant des données provenant de d'autres tableaux (onglets bleu ciel ci-dessous)
Je souhaite rajouter une bordure noire dans un tableau par VBA mais je n'y arrive pas. La bordure noire doit séparer les informations situées entre 2 onglets bleu ciel :

Est-ce que vous pouvez m'aider ?
J'ai joint un fichier Excel illustratif : https://www.transfernow.net/dl/20220506lwZ8FzFK/KqP7JK6E
Merci de votre aide

Voici la VBA que j'ai codé :

Sub test()


'''xxxxxxxxxxxxxxxxx EFFACEMENT DES DONNEES EXIXTANTES xxxxxxxxxxxxxxxxxxxx'''''
ThisWorkbook.Activate
Sheets("SYNTHESE").Select
Range("B7:N100000").Select
Selection.Clear

'''xxxxxxxxxxxxxxxxx EFFACEMENT DES DONNEES EXIXTANTES xxxxxxxxxxxxxxxxxxxx'''''


Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer
Dim nbLignes As Long


', dest As Range
Dim Deb As Long
Set ws = ThisWorkbook.Worksheets("SYNTHESE")
Dim Sh As Worksheet, C As Range


For Each Sh In Sheets
If Sh.Tab.ColorIndex = 33 Then

'''''''''''''''''''''''''' RISK '''''''''''''


For Each cel In Sh.Range("A7:A" & Sh.Range("A" & Rows.Count).End(xlUp).Row)

dt = ws.Cells(Rows.Count, 2).End(xlUp).Row + 1

ws.Range("B" & dt) = cel.Offset(, 0)
ws.Range("C" & dt) = cel.Offset(, 1)
ws.Range("D" & dt) = cel.Offset(, 2)
ws.Range("E" & dt).Formula = ws.Range("X" & dt).Formula
ws.Range("F" & dt).Formula = ws.Range("Y" & dt).Formula
ws.Range("G" & dt).Formula = ws.Range("Z" & dt).Formula
ws.Range("H" & dt).Formula = ws.Range("AA" & dt).Formula
ws.Range("I" & dt).Formula = ws.Range("AB" & dt).Formula
ws.Range("J" & dt).Formula = ws.Range("AC" & dt).Formula
ws.Range("K" & dt).Formula = ws.Range("AD" & dt).Formula
ws.Range("L" & dt).Formula = ws.Range("AE" & dt).Formula
ws.Range("M" & dt).Formula = ws.Range("AF" & dt).Formula
ws.Range("N" & dt).Formula = ws.Range("AG" & dt).Formula

Next cel


'''''''''''''''''''''''''' RISK '''''''''''''


End If
Next Sh


''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''

Range("B7:N10000").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With

''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''ALIGNEMENT DE LA CELLULE B à N''''''''''''''''''''''''


''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''

Range("E7:N10000").Select
Application.CutCopyMode = False
Selection.Style = "Comma"
Selection.NumberFormat = _
"_-* #,##0.0 _€_-;-* #,##0.0 _€_-;_-* ""-""?? _€_-;_-@_-"
Selection.NumberFormat = "_-* #,##0 _€_-;-* #,##0 _€_-;_-* ""-""?? _€_-;_-@_-"


''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''mettre les cellules à "-"''''''''''''''''''''''''

''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE


ThisWorkbook.Sheets("MODELE").Range("A3:M4").Copy
With ws.Range("B1:N10000")
For i = 7 To dt
If .Range("B" & i) <> "Totalazerty" And .Range("B" & i) <> "" Then
.Rows(i).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
Next i
End With


''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE
''''''''''''''''''''''''zzzzzzzzzzzzzzzzzzzzzzzzzzz MISE EN PAGE

Range("P10").Select


End Sub

EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI

Merci d'y penser dans tes prochains messages.

Configuration: Windows / Chrome 101.0.4951.54

Afficher la suite

A voir également:

Vba linestyle options
Windows 11 afficher d'autres options - Guide
Accéder aux options de démarrage avancées de windows 10 - Guide
Excel compter cellule couleur sans vba - Guide
Voir les options - Forum Facebook
Options d'ergonomie - Guide

1 réponse

Réponse 1 / 1

Patrice33740 Messages postés 8561 Date d'inscription Statut Membre Dernière intervention 1 780

Bonjour,

Avec un fichier exemple, c'eût été plus simple ...

J'ai pas tout compris, notamment pourquoi copier les formules et pourquoi copier 2 lignes de formats.
Bref j'ai simplement repris la même méthode (qui me semble très lourde) et ajouté le trait manquant

Ça donne quelque chose comme :

Option Explicit
Sub test()
'
Dim wsh As Worksheet    ' feuille (de calcul)
Dim wsS As Worksheet    ' feuille Synthèse
Dim cel As Range        ' cellule
Dim noL As Long         ' numéro de ligne
Dim drL As Long         ' dernière ligne
Dim ofL As Long         ' offset ligne

  Set wsS = ThisWorkbook.Worksheets("SYNTHESE")
  ' Effacement des données et bordures existantes
  wsS.Range("B7:N100000").Clear
  wsS.Range("A7:A100000").Borders.LineStyle = xlLineStyleNone
  ' Copie des données et formules
  For Each wsh In ThisWorkbook.Worksheets
    With wsh
      If .Tab.ColorIndex = 33 Then
        ' Risk
        For Each cel In .Range("A7", .Cells(Rows.Count, "A").End(xlUp)).Cells
          drL = wsS.Cells(Rows.Count, "B").End(xlUp).Row + 1
          '  données
          wsS.Cells(drL, "B").Value = cel.Offset(, 0).Value
          wsS.Cells(drL, "C").Value = cel.Offset(, 1).Value
          wsS.Cells(drL, "D").Value = cel.Offset(, 2).Value
          '  formules
          For ofL = 0 To 9
            wsS.Cells(drL, "E").Offset(ofL).Formula = wsS.Cells(drL, "X").Offset(ofL).Formula
          Next ofL
        Next cel
        ' séparateur (uniquement en colonne "A" car la mise en page écrase les formats de B à N)
        wsS.Cells(drL, "A").Borders(xlEdgeBottom).LineStyle = xlContinuous
        wsS.Cells(drL, "A").Borders(xlEdgeBottom).Weight = xlThick
      End If
    End With
  Next wsh
  With wsS.Range("B7:N10000")
    ' Alignements cellules B à N
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    ' Mettre les cellules à "-"
    .Style = "Comma"
    .NumberFormat = "_-* #,##0 _€_-;-* #,##0 _€_-;_-* ""-""?? _€_-;_-@_-"
    ' Mise en page
    ThisWorkbook.Worksheets("MODELE").Range("A3:M4").Copy
    For noL = 1 To drL - 7
      If .Cells(noL, "B").Value <> "Totalazerty" And .Cells(noL, "B").Value <> "" Then
        .Rows(noL).PasteSpecial Paste:=xlPasteFormats
      End If
    Next noL
  End With
  ' Étendre le séparateur de B à N
  For noL = 7 To drL
    If wsS.Cells(noL, "A").Borders(xlEdgeBottom).Weight = xlThick Then
      wsS.Range(wsS.Cells(noL, "A"), wsS.Cells(noL, "N")).Borders(xlEdgeBottom).Weight = xlThick
    End If
  Next noL
  wsS.Range("P10").Activate

End Sub

Dreampower75 Messages postés 88 Date d'inscription Statut Membre Dernière intervention 2

Bonjour,

Merci cela fonctionne

Patrice33740 Messages postés 8561 Date d'inscription Statut Membre Dernière intervention 1 780 > Dreampower75 Messages postés 88 Date d'inscription Statut Membre Dernière intervention

De rien, j'étais de passage ...

Discussions similaires

Non envoyé. Appuyez pour réessayer. Problème d'envoi SMS pour un seul contact.

Voir les Options

Message "SMS Non envoyé"

"L'indice n'appartient à la sélection" + VBA

Erreur d'exécution 13 Incompatibilité de type

Votre réponse

Discussions similaires