Rajouter une bordure noire dans un tableau par VBA

Résolu/Fermé

Dreampower75 Messages postés 88 Date d'inscription jeudi 28 janvier 2021 Statut Membre Dernière intervention 18 juin 2022 - Modifié le 7 mai 2022 à 13:35
Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 - 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

A voir également:

Vba linestyle options
Windows 11 afficher plus d'options - Guide
Find vba - Astuces et Solutions
Incompatibilité de type vba ✓ - Forum Programmation
Vba attendre 1 seconde ✓ - Forum VB / VBA
Vba dernière colonne non vide ✓ - Forum VB / VBA

1 réponse

Réponse 1 / 1

Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 1 776
7 mai 2022 à 12:25

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 jeudi 28 janvier 2021 Statut Membre Dernière intervention 18 juin 2022 2
7 mai 2022 à 13:05

Bonjour,

Merci cela fonctionne

Patrice33740 Messages postés 8556 Date d'inscription dimanche 13 juin 2010 Statut Membre Dernière intervention 2 mars 2023 1 776 > Dreampower75 Messages postés 88 Date d'inscription jeudi 28 janvier 2021 Statut Membre Dernière intervention 18 juin 2022
7 mai 2022 à 13:31

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

Discussions similaires

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

Voir les Options

VBA : Range avec références variables..

VBA erreur 1004

ouverture d'un fichier excel à partir d'un code VBA

Discussions similaires

Newsletters