Bordure de tableau

Le 12/02/2021 à 10:32

Bonjour

ci joint mon fichier.

Dans la partie du bas du code je veux traiter les bordures du tableau, j'arrive à faire l'en-tête mais pas le reste.

22toto.xlsm (46.25 Ko)

je précise que quand on lance le fichier, il y a 1 bouton, on click dessus, cela creer une 2eme feuille "Panne retour" et c'est là que je veux les bordures..

Le 12/02/2021 à 12:03
5toto.xlsm (54.84 Ko)

En espérant que ca te va.

Après je vais pas te mentir je trouve que ton code est très lent pour un extract. Mais j'avais pas envie de changer toute ta logique, tu devrais essayer de diminuer l'utilisation de selection et le nombre de boucle code en réunissant le plus de truc mais ca sera peut être long à tout refaire. ;)

Ton problème venait du fait que tu faisait une boucle sur les lignes de 6 à la dernière sans changer ta selection. Donc j'ai juste modifier la selection comme tu voulais.

Le 12/02/2021 à 12:06

Bonjour, effectivement la fin avec le For Y comprends pas l'utilité ?

Faites directement la sélection de la plage complète pour le cadrage final . de A6 à E + dernière ligne.

Range("A6:E" & der).Select 'Bordure tout le reste du tableau
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
Le 12/02/2021 à 12:07

Bonjour,

Pourquoi ne pas mettre les données sous forme de tableau (structuré) avec ou sans en-têtes et synthétise avec un TCd (tableau croisé dynamique) ?

On pourrait éviter l'usage de VBA (non maîtrisé) !?

Cdlt.

Le 12/02/2021 à 12:39

Bonjour à tous,

Un essai dans l'idée de départ de quattro1 ...

Modif ... j'ai supprimé les derniers select ...

Option Explicit
Sub Macro1()
   ' Panne_retour Macro '
Dim nomfeuille As String

   Application.ScreenUpdating = False

   'RECUPERE LE NOM DE LA FEUILLE
   nomfeuille = ActiveSheet.Name

   'CREATION DE LA FEUILLE PANNE RETOUR
   Sheets.Add
   ActiveSheet.Name = "Panne retour"

   'SUPPRIME LES 9 PREMIERES LIGNES
   Dim s%
   Worksheets(nomfeuille).Activate
   For s = 9 To 1 Step -1
      If Cells(s, 1) = "" Then Rows(s).EntireRow.Delete
   Next s

   'COPIE LES COLONNES
   Worksheets(nomfeuille).Columns("R").Copy Sheets("Panne retour").Columns("A")

   Worksheets(nomfeuille).Columns("Q").Copy Sheets("Panne retour").Columns("B")

   'INSERT 5 LIGNES AU-DESSUS
   With Sheets("Panne retour")
      .Activate
      .Rows("1:5").Insert

      'CONVERTIR EN MAJUSCULE LES LETTRES "aa" COLONNE 2
      Dim x As Variant

      For Each x In .Range("B6:B150")      'PR
         x.Value = UCase(x.Value)
      Next

      'CENTRER LES VALEURS COLONNE 2 'PR
      With .Range("B6:B150")
         .HorizontalAlignment = xlHAlignCenter      'ou xlHAlignLeft ou xlHAlignRight
         .VerticalAlignment = xlVAlignCenter      'ou xlVAlignTop ou xlVAlignBottom
      End With

      'EN-TETE
      .Cells(5, 1) = "Désignation"
      .Range("A5").Font.Bold = True
      .Cells(5, 2) = "Code"
      .Range("B5").Font.Bold = True
      .Cells(5, 3) = "Nb d'intervention"
      .Range("C5").Font.Bold = True
      .Cells(5, 4) = "Curatif"
      .Range("D5").Font.Bold = True
      .Cells(5, 5) = "Préventif"
      .Range("E5").Font.Bold = True

      'POSE LA QUESTION DU MOIS CONCERNE
      Dim mois As String

      mois = InputBox("Quel est le mois : ", "Mois")
      .Cells(3, 1).Value = "Mois de : " + mois

      'DEBUT DU CLASSEMENT       'PR jusqu'à la fin
      Dim Tablo, Dico As Object
      Dim i As Long
      Dim TT, T, clé
      Tablo = .Range("A5").CurrentRegion
      Set Dico = CreateObject("Scripting.Dictionary")

      For i = 2 To UBound(Tablo, 1)
         clé = Tablo(i, 1) & "|" & Tablo(i, 2)
         Dico(clé) = Dico(clé) + 1
      Next i

      .Range("A5").CurrentRegion.Offset(1, 0).ClearContents      'Efface la ligne

      ReDim TT(1 To Dico.Count, 1 To 3)
      i = 0
      For Each clé In Dico.keys
         i = i + 1
         T = Split(clé, "|")
         TT(i, 1) = T(0)
         TT(i, 2) = T(1)
         TT(i, 3) = Dico(clé)
      Next

      .Range("A6").Resize(UBound(TT, 1), UBound(TT, 2)) = TT

      ' FILTRE/TRIE CROISSANT
      .Range("A5").CurrentRegion.AutoFilter

      .AutoFilter.Sort.SortFields.Add2 Key:=.Range("B5:B2000"), SortOn:=xlSortOnValues, _
                                       Order:=xlAscending, DataOption:=xlSortNormal

      With .AutoFilter.Sort
         .Header = xlYes
         .MatchCase = False
         .Orientation = xlTopToBottom
         .SortMethod = xlPinYin
         .Apply
      End With

      'SOMME DES INTERVENTIONS
      Dim MaColonne As Single
      Dim MaPremiereLigne As Single
      Dim MaDerniereLigne As Single
      Dim UneLigne As Single
      Dim MaSomme As Single

      MaColonne = 3      '(= colonne "C")
      MaPremiereLigne = 6
      MaDerniereLigne = 110

      MaSomme = 0

      For UneLigne = MaPremiereLigne To MaDerniereLigne
         If IsNumeric(.Cells(UneLigne, MaColonne).Value) = True Then _
            MaSomme = MaSomme + .Cells(UneLigne, MaColonne).Value
      Next UneLigne

      ' CLASSEMENT "PREVENTIF"
      Dim derL%, bcl%

      derL = .Cells(Rows.Count, 1).End(xlUp).Row

      For bcl = 1 To derL
         If .Cells(bcl, 2) = 41 Or .Cells(bcl, 2) = 43 Or _
            .Cells(bcl, 2) = 58 Or .Cells(bcl, 2) = 59 Or _
            .Cells(bcl, 2) = 62 Or .Cells(bcl, 2) = 101 Or _
            .Cells(bcl, 2) = "aa" Or .Cells(bcl, 2) = "AA" Then
            .Cells(bcl, 3).Copy
            .Cells(bcl, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                                        SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
         End If
      Next bcl

      ' CLASSEMENT "CURATIF"
      For bcl = 1 To derL
         Select Case .Cells(bcl, 2)
            Case 6 To 22, 25 To 34, 38, 39, 42, 44, 45, 47, 49 To 57, 60, 61, 63 To 100, 102, 991 To 996
               If .Cells(bcl, 2) \ 1 = .Cells(bcl, 2) Then
                  .Cells(bcl, 3).Copy
                  .Cells(bcl, 4).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
                                              SkipBlanks:=False, Transpose:=False
                  Application.CutCopyMode = False
               End If
         End Select
      Next bcl

      'AFFICHER TOTAL + SOMME + MISE EN FORME du TEXTE
      Dim derLigne%

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

      .Cells(derLigne, 3).Value = MaSomme
      .Cells(derLigne, 3).Font.Bold = True
      .Cells(derLigne, 3).Font.Size = 16
      .Cells(derLigne, 3).Borders.Value = 1
      .Cells(derLigne, 3).Font.ColorIndex = 32

      .Cells(derLigne, 2).Value = "TOTAL"
      .Cells(derLigne, 2).Font.Bold = True
      .Cells(derLigne, 2).Font.Size = 16
      .Cells(derLigne, 2).Font.Underline = True
      .Cells(derLigne, 2).Font.ColorIndex = 32

      .Cells(3, 1).Font.Underline = True

      'AJUSTEMENT AUTOMATIQUE DES COLONNES
      .Cells.Select
      .Cells.EntireColumn.AutoFit
      .Range("A1").Select

      'BORDURE TABLEAU
      Dim der%, y%

      der = .Cells(Rows.Count, 1).End(xlUp).Row

      With .Range("A5:E5")      'Bordure en-tête
         .Borders(xlDiagonalDown).LineStyle = xlNone
         .Borders(xlDiagonalUp).LineStyle = xlNone
         With .Borders(xlEdgeLeft)
            .LineStyle = xlDouble
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThick
         End With
         With .Borders(xlEdgeTop)
            .LineStyle = xlDouble
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThick
         End With
         With .Borders(xlEdgeBottom)
            .LineStyle = xlDouble
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThick
         End With
         With .Borders(xlEdgeRight)
            .LineStyle = xlDouble
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .Weight = xlThick
         End With

         .Borders(xlInsideVertical).LineStyle = xlNone
         .Borders(xlInsideHorizontal).LineStyle = xlNone
      End With

      For y = 6 To der      'Bordure tout le reste du tableau
         With .Range("A" & y & ":E" & y)
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            With .Borders(xlEdgeLeft)
               .LineStyle = xlContinuous
               .ColorIndex = xlAutomatic
               .TintAndShade = 0
               .Weight = xlThin
            End With
            With .Borders(xlEdgeTop)
               .LineStyle = xlContinuous
               .ColorIndex = xlAutomatic
               .TintAndShade = 0
               .Weight = xlThin
            End With
            With .Borders(xlEdgeBottom)
               .LineStyle = xlContinuous
               .ColorIndex = xlAutomatic
               .TintAndShade = 0
               .Weight = xlThin
            End With
            With .Borders(xlEdgeRight)
               .LineStyle = xlContinuous
               .ColorIndex = xlAutomatic
               .TintAndShade = 0
               .Weight = xlThin
            End With
            With .Borders(xlInsideVertical)
               .LineStyle = xlContinuous
               .ColorIndex = xlAutomatic
               .TintAndShade = 0
               .Weight = xlThin
            End With
            With .Borders(xlInsideHorizontal)
               .LineStyle = xlContinuous
               .ColorIndex = xlAutomatic
               .TintAndShade = 0
               .Weight = xlThin
            End With
         End With
      Next y
      .Range("A1").Select      'Positionne le curseur
   End With
End Sub

ric

Le 12/02/2021 à 21:51

ok merci

du coup j'ai un petit soucis avec cette ligne :

ReDim TT(1 To Dico.Count, 1 To 3)

ci joint mon fichier :

9test.xlsm (116.17 Ko)
Le 12/02/2021 à 22:09

Bonjour à tous,

Ici sur ma machine > je n'ai aucun souci > la macro complète le traitement correctement ...

ric

Le 15/02/2021 à 16:40

L'utilisation de dictionnaire nécessite que tu ajoutes la références avant :

Outils > Références > coché "Microsoft Scripting Runtime"

Le 15/02/2021 à 18:04

Bonjour à tous,

@ tenders_vba > pourtant son fichier d'origine n'utilise pas "Microsoft Scripting Runtime" et il semblait fonctionner ...

Sur ma machine > le fichier de quattro1 fonctionne et il n'utilise pas "Microsoft Scripting Runtime" ...

ric

Le 17/02/2021 à 19:18

Merci à tous cela fct

Rechercher des sujets similaires à "bordure tableau"