Optimiser de code (procédure de mise en forme des données) [Résolu]

Question

Posez votre question Signaler

Optimiser de code (procédure de mise en forme des données) [Résolu]

SERIEUXETCOOL

Messages postés: 336
Date d'inscription: dimanche 3 avril 2011
Statut: Membre
Dernière intervention: 12 juin 2012

- 22 avril 2012 à 14:08 - Dernière réponse : SERIEUXETCOOL

Messages postés: 336
Date d'inscription: dimanche 3 avril 2011
Statut: Membre
Dernière intervention: 12 juin 2012

- 26 avril 2012 à 16:40

Visual Basic 6 Posez votre question Signaler

Bonjour à tous,

Dans le cadre d'une de mes appli par vba je rencontre un problème d'optimisation de code. Il s'agit d'une procédure qui me permet de faire toute une mise en forme de mes données se trouvant sur une feuille Excel.

Cette procédure a été réalisée avec l'aide de l'enregistreur de macro et je ne suis pas sur d'avoir fait convenablement le ménage

Je suis convaincu que la procédure peut être améliorée de façon à s’exécuter BEAUCOUP plus rapidement qu'elle ne l'est actuellement.

Voici le code d'appel qui permet de charger un exemple sur la feuille :

Option Explicit

Public Sub TEST()

Range("E4") = "TESTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT"
Call MISE_EN_FORME(Range("B2:E10"), Range("B2:E2"), Range("B3,C3,D3,E3"), Range("B2,B3,C3,D3,E3"), Range("B2"), , Range("B4:E4"))

End Sub

Et maintenant la procédure en elle même :

Private Sub MISE_EN_FORME(Optional Tableau As Variant, Optional Fusion As Variant, Optional Bordure As Variant, Optional Gras As Variant, Optional Violet As Variant, Optional Gris As Variant, Optional Vert As Variant, Optional Orange As Variant)

Dim colonne As Long

'----------------
    Cells.Select
    With Selection.Font
        .Name = "Cambria"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMajor
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
'-----------------

'-----------------
    If IsMissing(Tableau) Then
    GoTo Tableau
    End If
    Tableau.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .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
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
Tableau:
'-------------

'-------------
    If IsMissing(Fusion) Then
    GoTo Fusion
    End If
    Fusion.Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
Fusion:
'------------

'------------
    If IsMissing(Bordure) Then
    GoTo Bordure
    End If
    Bordure.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
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .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
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Bordure:
'------------

'-----------
    If IsMissing(Gras) Then
    GoTo Gras
    End If
    Gras.Font.Bold = True
Gras:
'----------

'----------
    If IsMissing(Violet) Then
    GoTo Violet
    End If
    Violet.Select
    With Selection.Interior
        .Pattern = xlPatternRectangularGradient
        .Gradient.RectangleLeft = 0.5
        .Gradient.RectangleRight = 0.5
        .Gradient.RectangleTop = 0.5
        .Gradient.RectangleBottom = 0.5
        .Gradient.ColorStops.Clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .Color = RGB(204, 0, 255)
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .Color = RGB(204, 192, 218)
    End With
Violet:
'---------

'----------
    If IsMissing(Gris) Then
    GoTo Gris
    End If
    Gris.Select
    With Selection.Interior
        .Pattern = xlPatternRectangularGradient
        .Gradient.RectangleLeft = 0.5
        .Gradient.RectangleRight = 0.5
        .Gradient.RectangleTop = 0.5
        .Gradient.RectangleBottom = 0.5
        .Gradient.ColorStops.Clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .Color = RGB(165, 165, 165)
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .Color = RGB(216, 216, 216)
    End With
Gris:
'---------

'----------
    If IsMissing(Vert) Then
    GoTo Vert
    End If
    Vert.Select
    With Selection.Interior
        .Pattern = xlPatternRectangularGradient
        .Gradient.RectangleLeft = 0.5
        .Gradient.RectangleRight = 0.5
        .Gradient.RectangleTop = 0.5
        .Gradient.RectangleBottom = 0.5
        .Gradient.ColorStops.Clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .Color = RGB(0, 176, 80)
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .Color = RGB(146, 208, 80)
    End With
Vert:
'---------

'----------
    If IsMissing(Orange) Then
    GoTo Orange
    End If
    Orange.Select
    With Selection.Interior
        .Pattern = xlPatternRectangularGradient
        .Gradient.RectangleLeft = 0.5
        .Gradient.RectangleRight = 0.5
        .Gradient.RectangleTop = 0.5
        .Gradient.RectangleBottom = 0.5
        .Gradient.ColorStops.Clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .Color = RGB(255, 192, 0)
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .Color = RGB(252, 213, 180)
    End With
Orange:
'---------

'---------
Rows("1:1").Select 'Réglage de la hauteur
Range(Selection, Selection.End(xlDown)).RowHeight = 16

colonne = Cells.Find("*", , , , xlByColumns, xlPrevious).Column 'Compte le nombre de colonnes dynamiques

Range("A:A," & Nombre_en_Lettre(colonne + 1) & ":" & Nombre_en_Lettre(colonne + 1)).ColumnWidth = 2 'Réglage de la largeur

Columns("A:" & Nombre_en_Lettre(colonne)).EntireColumn.AutoFit 'Ajuste la largeur au contenu

Range("A1:" & Nombre_en_Lettre(colonne + 1) & "1").Select 'Pour régler le zoom de la page pour que sa rentre complètement
ActiveWindow.Zoom = True

Range("A1:A1").Select 'Pour se replacer de manière propre sur la feuille
'-------------

End Sub
Function Nombre_en_Lettre(Nombre As Long) As String

If Nombre > 0 And Nombre < 257 Then
    Nombre_en_Lettre = Split(Cells(Nombre).Address, "$")(1)
Else
    Nombre_en_Lettre = Error(9)
End If

End Function

Vu la longueur de cette procédure...On doit pouvoir épurer pleinnnnnnns de choses je pense. Mais qu'est ce qui est utile et qu'est ce qui ne l'est pas ??? La méthode que j’emploie est elle bonne ?

Trop de questions sans réponses pour moi...

Merci de vos conseils.

André

Afficher la suite

A voir également:

11 réponses

Signaler Commenter la réponse de SERIEUXETCOOL

SERIEUXETCOOL

Messages postés: 336
Date d'inscription: dimanche 3 avril 2011
Statut: Membre
Dernière intervention: 12 juin 2012

1 26 avril 2012 à 16:40

3

Merci

Après avoir cogité un peu plus sur ce code, j'ai décidé de poster la dernière version améliorée de ce dernier. Cette version réalise les mêmes choses avec certaines lignes de code inutiles en moins et quelques modifis minimes.

D'autre part, pour ceux qui voudraient utiliser en entrée un Range qui sélectionnerait plusieurs colonnes ou lignes distinctes voici un exemple d'appel qui fonctionne. Ce n'est pas si trivial qu'il n'y parait pour les débutants. Si ça peut servir...

André

Pour appeler la procédure :

Call MISE_EN_FORME(,,,,, "J8:L" & n - 2 & ",O8:O" & n - 2)

Pour le code de la procédure :

Option Explicit

Public Sub MISE_EN_FORME(Optional Tableau As Variant, Optional Fusion As Variant, Optional Bordure As Variant, Optional Gras As Variant, Optional Violet As Variant, Optional Gris As Variant, Optional Vert As Variant, Optional Orange As Variant)
  
  Dim traiter As Range
  Dim colonne As Long
  Dim gauche As Integer, haut As Integer, bas As Integer, droit As Integer, int_vertical As Integer, int_horizontal As Integer

  '----------------
  With ActiveSheet.Cells.Font
    .Name = "Cambria"
    .Size = 12
  End With
  With ActiveSheet.Cells
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
  End With
  '-----------------
  If Not IsMissing(Tableau) Then
    Set traiter = Range(Tableau)
    With traiter
      .Borders(xlDiagonalDown).LineStyle = xlNone
      .Borders(xlDiagonalUp).LineStyle = xlNone
    End With
    gauche xlMedium: haut xlMedium:  bas = xlMedium: droit = xlMedium
    int_vertical xlThin: int_horizontal xlThin
    bordures traiter, gauche, haut, bas, droit, int_vertical, int_horizontal
  End If
'-------------
  If Not IsMissing(Fusion) Then
    Set traiter = Range(Fusion)
    traiter.MergeCells = True
  End If
'------------
  If Not IsMissing(Bordure) Then
    Set traiter = Range(Bordure)
    With traiter
      .Borders(xlDiagonalDown).LineStyle = xlNone
      .Borders(xlDiagonalUp).LineStyle = xlNone
    End With
    gauche xlMedium: haut xlMedium:  bas = xlMedium: droit = xlMedium
    int_vertical xlNone: int_horizontal xlNone
    bordures traiter, gauche, haut, bas, droit
  End If
'------------
  If Not IsMissing(Gras) Then
    Set traiter = Range(Gras)
    traiter.Font.Bold = True
  End If
'----------
  If Not IsMissing(Violet) Then
    Set traiter = Range(Violet)
    couleurs traiter, RGB(204, 0, 255), RGB(204, 192, 218)
  End If
'---------
  If Not IsMissing(Gris) Then
    Set traiter = Range(Gris)
    couleurs traiter, RGB(165, 165, 165), RGB(216, 216, 216)
  End If
'---------
  If Not IsMissing(Vert) Then
    Set traiter = Range(Vert)
    couleurs traiter, RGB(0, 176, 80), RGB(146, 208, 80)
  End If
'---------
  If Not IsMissing(Orange) Then
    Set traiter = Range(Orange)
    couleurs traiter, RGB(255, 192, 0), RGB(252, 213, 180)
  End If
'---------

'---------
  Rows("1:1").Select 'Réglage de la hauteur
  Range(Selection, Selection.End(xlDown)).RowHeight = 16

  colonne = Cells.Find("*", , , , xlByColumns, xlPrevious).Column 'Compte le nombre de colonnes dynamiques

  Range("A:A," & Nombre_en_Lettre(colonne + 1) & ":" & Nombre_en_Lettre(colonne + 1)).ColumnWidth = 2 'Réglage de la largeur

  Columns("A:" & Nombre_en_Lettre(colonne)).EntireColumn.AutoFit 'Ajuste la largeur au contenu

  Range("A1:" & Nombre_en_Lettre(colonne + 1) & "1").Select 'Pour régler le zoom de la page pour que sa rentre complètement
  ActiveWindow.Zoom = True

  Range("A1:A1").Select 'Pour se replacer de manière propre sur la feuille
  ActiveWindow.ScrollRow = 1 'Pour placer les ascenseurs en haut
  ActiveWindow.ScrollColumn = 1 'Pour placer les ascenseurs à gauche
'-------------

  Set traiter = Nothing

End Sub

Function Nombre_en_Lettre(Nombre As Long) As String

If Nombre > 0 And Nombre < 257 Then
    Nombre_en_Lettre = Split(Cells(Nombre).Address, "$")(1)
Else
    Nombre_en_Lettre = Error(9)
End If

End Function

Public Sub bordures(traiter As Range, gauche As Integer, haut As Integer, bas As Integer, droit As Integer, Optional int_vertical As Integer, Optional int_horizontal As Integer)
   
   With traiter
     .Borders.LineStyle = xlContinuous
     .Borders(xlEdgeLeft).Weight = gauche
     .Borders(xlEdgeTop).Weight = haut
     .Borders(xlEdgeBottom).Weight = bas
     .Borders(xlEdgeRight).Weight = droit
     On Error Resume Next
     .Borders(xlInsideVertical).Weight = int_vertical
     .Borders(xlInsideHorizontal).Weight = int_horizontal
     On Error GoTo 0
   End With

End Sub

Public Sub couleurs(traiter As Range, couleur1 As Long, couleur2 As Long)
  
  With traiter.Interior
         .Pattern = xlPatternRectangularGradient
        .Gradient.RectangleLeft = 0.5
        .Gradient.RectangleRight = 0.5
        .Gradient.RectangleTop = 0.5
        .Gradient.RectangleBottom = 0.5
        .Gradient.ColorStops.Clear
  End With
  
  With traiter.Interior.Gradient.ColorStops.Add(0)
        .Color = couleur1
  End With
  
  With traiter.Interior.Gradient.ColorStops.Add(1)
        .Color = couleur2
  End With

End Sub

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 204 internautes nous ont dit merci ce mois-ci

Signaler Commenter la réponse de ucfoutu

ucfoutu

Messages postés: 18039
Date d'inscription: lundi 7 décembre 2009
Statut: Modérateur
Dernière intervention: 11 avril 2018

214 22 avril 2012 à 16:56

0

Merci

Bonjour,
Hé bé ! (tu es bien gourmand).
Difficile de t'aider à accroître la rapidité (sauf sur un ou deux points)
Il y a par contre beaucoup de ménage à faire !
Déjà :
Peux-tu expliquer pourquoi tu définis deux fois les bordures si tableau ?
Exemple :*

With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
End With
....
'puis
...
 With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With

Pour dire deux fois la même chose, sauf pour le poids (Weight). C'est d'autant plus surprenant que, comme avec Louis XVI, le dernier à parler aura raison (xlMedium) ?
Un ménage te sera proposé après ta réponse .
________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

Signaler Commenter la réponse de Utilisateur anonyme

Utilisateur anonyme 22 avril 2012 à 17:30

0

Merci

Bonjour,

Puisque tu vas toujours sur les mêmes cellules, pourquoi ne pas te faire une feuille-modèle avec les mises en formes constantes. Ensuite tu repasses avec juste ce quIl faut changer. Déjà, cela t'éviterait de repartir à zéro chaque fois.

Et puis, pourquoi pas une mise en forme conditionelle ? Tu as droit à quatre formats; le format de base plus 3 conditions.

Tout ce qui peut être fait directement sans VBA, c'est déjà plus rapide que VBA

Signaler Commenter la réponse de SERIEUXETCOOL

SERIEUXETCOOL

Messages postés: 336
Date d'inscription: dimanche 3 avril 2011
Statut: Membre
Dernière intervention: 12 juin 2012

1 22 avril 2012 à 18:04

0

Merci

Bonsoir cmarcotte,

Malheureusement je ne vais pas toujours sur les mêmes cellules. C'est justement le but de la procédure : Appliquer une mise en forme uniforme ou que l'on soit.

Donc les cellules changent, les feuilles aussi.

De plus, et pour répondre à ta remarque, les feuilles sont déjà créées par vba. Elles sont donc fraichement nouvelles, et j'applique ensuite la mise en forme qui me conviens par code toujours.

Cette procédure me conviens parfaitement quand la feuille contient peu de données. Mais elle est tellement mal optimisée que dès lors que la feuille contient un gros lot de données, la macro rame. On le ressens assez bien.

Je pense plus qu'il faille épurer que modifier la méthode. Je peux me tromper bien sur.

Qu'en pense tu maintenant Cmarcotte ?

Signaler Commenter la réponse de SERIEUXETCOOL

SERIEUXETCOOL

Messages postés: 336
Date d'inscription: dimanche 3 avril 2011
Statut: Membre
Dernière intervention: 12 juin 2012

1 22 avril 2012 à 19:30

0

Merci

Aie aie aie ! Je suis complètement passé au travers de ta réponse Ucfoutu !!!

Dsl je ne l'avais pas vu.

Donc avec tout mon retard (je m'en excuse, c'est ma faute), je peux répondre.

Pourquoi je définis 2 fois les bordures de mon tableau ??? Et bien euuuh c'est à cause de l'enregistreur de macro qui agit de manière séquentielle (c'est son rôle en même temps ). Moi je veux que la plage sélectionnée (qui représente le tableau) aie toutes ses bordures en fines ET uniquement les bordures extérieures en plus gros.

Du coup avec l'enregistreur il me dit : Premier tableau avec toutes les bordures en fines. Puis rebelote, deuxième tableau (qui en fait est le même) toutes les bordures extérieures en gros.

Je ne suis pas parvenu à fusionner les 2 étapes en un seul step. J'obtenais une erreur car je m'y prenais mal sans doute. Donc j'avais laissé les deux étapes dissociées et mon code ne plantait pas.

Mais c'est pas fin du tout j'en conviens

Je vais quand même lister les actions qui intéressement dans la mise en forme. Dans l'ordre sa donne ceci :

-Sur toutes les cellules, Cambria, 12, Centrer, Aligner au centre (c'est la base de départ). Ça me stresse de travailler avec autre choses sinon...

-Pour Tableau c'est Toutes les bordures, puis Bordures épaisse en encadré

-Pour Fusion c'est Fusionner et centrer

-Pour Bordure c'est Bordures épaisse en encadré uniquement

-Pour Gras, c'est mettre le contenu de la cellule en gras

-Pour Violet/Gris/Vert/Orange c'est appliquer la couleur que j'ai mis avec les 2 gradients

-Et puis sur la fin c'est définir l'épaisseur des lignes, puis définir l'épaisseur de la première colonne et de la dernière. De faire en sorte que le contenu soit ajusté aux cellules.

-La dernière chose est de se replacer proprement en cellule A1

Rien que ça tu me diras^^

Si je n'ai pas été clair, je peux donner d'autres détails. Mais je pense que la mise en forme que je demande est "basique" finalement.

Bien cordialement,

André

Ps : Ucfoutu, je n'ai pas eu droit à l'ogre qui crie à tue tête "A voté !".
Ici, il était plutôt soft.

Signaler Commenter la réponse de ucfoutu

ucfoutu

Messages postés: 18039
Date d'inscription: lundi 7 décembre 2009
Statut: Modérateur
Dernière intervention: 11 avril 2018

214 22 avril 2012 à 19:48

0

Merci

Bon,
1) je dîne
2) j'écoute les résultats du vote
3) je te fais cela en beaucoup plus court et moins lent
A plus.

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

Signaler Commenter la réponse de bigfish_le vrai

bigfish_le vrai

Messages postés: 1839
Date d'inscription: vendredi 13 mai 2005
Statut: Membre
Dernière intervention: 20 novembre 2013

8 23 avril 2012 à 11:43

0

Merci

Salut,

je ne viens pas remettre en question ce qui à été fait mais je viens juste amener 2 petites chose peu connues à propos des bordures.

1) les méthodes de mise en forme des bordures peuvent être appliquées directement à la collection Bordures

2) il existe une méthode spécifique pour les bordures de contour.

Donc pour une plage avec des bordures différentes autour et à l’intérieur on peu écrire:

Sub Demo()
    Dim maplage As Range
    Set maplage = Selection
    With maplage
        With .Borders
            .Weight = xlThin 's'applique à toute les bordures intérieur et extérieur
        End With
        .BorderAround , xlThick 's'applique seulement au bordures de contour
    End With
End Sub

A+

Signaler Commenter la réponse de ucfoutu

ucfoutu

Messages postés: 18039
Date d'inscription: lundi 7 décembre 2009
Statut: Modérateur
Dernière intervention: 11 avril 2018

214 23 avril 2012 à 13:00

0

Merci

Bonjour, bigfish_le vrai
Tu as raison.
J'ai toutefois hésité à l'utiliser. Pourquoi ?
En raison du cas "merge", qui ne souffre aucune bordure à l'intérieur et pour lequel un premier essai avait généré une erreur. C'est même là la raison du seul on error resume next du code suggéré, y compris avec 2 paramètres optionnels.

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

Signaler Commenter la réponse de SERIEUXETCOOL

SERIEUXETCOOL

Messages postés: 336
Date d'inscription: dimanche 3 avril 2011
Statut: Membre
Dernière intervention: 12 juin 2012

1 24 avril 2012 à 22:25

0

Merci

Bonsoir le Forum,

Bien j'ai pu tester ton code Ucfoutu...Il est juste top !

Plus court, parfaitement reproductible et performant de plus. Bref perfect

Pour info, en cumulant ce code amélioré et le code amélioré que tu m'avais proposé pour importer les données de mon fichier texte...Je divise par 2 mon temps d’exécution global. C'est juste du bonheur.

Je peux maintenant travailler aisément avec des fichiers de 100 000 lignes*8 colonnes sans le moindre soucis.

Merci à vous deux Ucfoutu et bigfish_le vrai pour m'avoir aidé à franchir cette limite.

Post résolu

A tous, bonne soirée.

Bien cordialement,

André

Ps : Ucfoutu

- cela ne veut pas dire que j'approuve
- il est fort vraisemblable que tu pourrais t'y prendre autrement qu'ainsi, mais là ... c'est toute ton appli, qu'il faudrait connaître.

J'ai bien noté que la méthode que j'emploie n'est sans doute pas la plus appropriée. Ce qui veut également dire que l'on pourrait mieux faire en cas de besoin. Pour le moment je ne suis pas à 20 secondes prêt. Donc je suis content. Le jour ou j'aurais besoin de passer de la limite 100 000 lignes à 1 000 000 de lignes je pense que j'aurais besoin de ré-optimiser l'ensemble de mon code. Pour l'instant, pas la peine de se prendre la tête. C'est parfaitement en accord avec la réponse que j'espérais avoir du forum. Néanmoins c'est noté.

Signaler Commenter la réponse de SERIEUXETCOOL

SERIEUXETCOOL

Messages postés: 336
Date d'inscription: dimanche 3 avril 2011
Statut: Membre
Dernière intervention: 12 juin 2012

1 25 avril 2012 à 00:32

0

Merci

Re-Bonsoir,

Je reviens très rapidement sur le code proposé par Ucfoutu. Lors de mes tests, j'ai pu regarder la rapidité d'exécution de la procédure "MISE_EN_FORME" sur un gros fichier. Je n'ai donc pas transférer la procédure sur mes anciennes applis.

Le code fonctionne bien...mais il y a une toute petite feinte que je ne parviens pas à résoudre.

Dans le code que je propose, une fois que j'appelle ma procédure "MISE_EN_FORME" je peux entrer un paramètre en tant qu'Union. Et je ne parviens pas à trouver une solution équivalente avec ce nouveau code ???

Quelle serait la méthode, l'astuce, la modfif de code pour pouvoir entrer un Union de Range en tant que paramètre d'entré ? C'est possible ou c'est une limitation du nouveau code du coup ?

Ucfoutu, si tu as l'occasion de repasser par ici je suis intéressé pour savoir comment passer outre mon Union.

Merci d'avance.

André

Répondre Posez votre question

ucfoutu · Accepted Answer · 2012-04-23T11:14:36+0200

Voilà en tout cas ce que fait ton code, écrit autrement (en évitant redondances, tant de code que d'actions) :

Private Sub CommandButton1_Click()
  Range("E4") = "TESTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT"
  Call MISE_EN_FORME("B2:E10", "B2:E2", "B3,C3,D3,E3", "B2,B3,C3,D3,E3", "B2", , "B4:E4")
End Sub
Private Sub MISE_EN_FORME(Optional Tableau As Variant, Optional Fusion As Variant, Optional Bordure As Variant, Optional Gras As Variant, Optional Violet As Variant, Optional Gris As Variant, Optional Vert As Variant, Optional Orange As Variant)
  Dim traiter As Range, colonne As Long
  Dim gauche As Integer, haut As Integer, bas As Integer, droit As Integer, int_vertical As Integer, int_horizontal As Integer

  Application.ScreenUpdating = False
  '----------------
  With ActiveSheet.Cells.Font
    .Name = "Cambria"
    .Size = 12
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMajor
  End With
  With ActiveSheet.Cells
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
  End With
  '-----------------
  If Not IsMissing(Tableau) Then
    Set traiter = Range(Tableau)
    With traiter
      .Borders(xlDiagonalDown).LineStyle = xlNone
      .Borders(xlDiagonalUp).LineStyle = xlNone
    End With
    gauche xlMedium: haut xlMedium:  bas = xlMedium: droit = xlMedium
    int_vertical xlThin: int_horizontal xlThin
    bordures traiter, gauche, haut, bas, droit, int_vertical, int_horizontal
  End If
'-------------
  If Not IsMissing(Fusion) Then
    Set traiter = Range(Fusion)
    With traiter
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
      .WrapText = False
      .Orientation = 0
      .AddIndent = False
      .IndentLevel = 0
      .ShrinkToFit = False
      .ReadingOrder = xlContext
      .MergeCells = True
    End With
  End If
'------------
  If Not IsMissing(Bordure) Then
    Set traiter = Range(Bordure)
    With traiter
      .Borders(xlDiagonalDown).LineStyle = xlNone
      .Borders(xlDiagonalUp).LineStyle = xlNone
    End With
    gauche xlMedium: haut xlMedium:  bas = xlMedium: droit = xlMedium
    int_vertical xlNone: int_horizontal xlNone
    bordures traiter, gauche, haut, bas, droit
  End If
'------------
  If Not IsMissing(Gras) Then
    Set traiter = Range(Gras)
    traiter.Font.Bold = True
  End If
'----------
  If Not IsMissing(Violet) Then
    Set traiter = Range(Violet)
    traiter.Font.Bold = True
    couleurs traiter, RGB(204, 0, 255), RGB(204, 192, 218)
  End If
'---------
  If Not IsMissing(Gris) Then
    Set traiter = Range(Gris)
    traiter.Font.Bold = True
    couleurs traiter, RGB(165, 165, 165), RGB(216, 216, 216)
  End If
'---------
  If Not IsMissing(Vert) Then
    Set traiter = Range(Vert)
    couleurs traiter, RGB(0, 176, 80), RGB(146, 208, 80)
  End If
'---------
  If Not IsMissing(Orange) Then
    Set traiter = Range(Orange)
    couleurs traiter, RGB(255, 192, 0), RGB(252, 213, 180)
  End If
'---------

'---------
  Rows("1:1").Select 'Réglage de la hauteur
  Range(Selection, Selection.End(xlDown)).RowHeight = 16

  colonne = Cells.Find("*", , , , xlByColumns, xlPrevious).Column 'Compte le nombre de colonnes dynamiques

  Range("A:A," & Nombre_en_Lettre(colonne + 1) & ":" & Nombre_en_Lettre(colonne + 1)).ColumnWidth = 2 'Réglage de la largeur

  Columns("A:" & Nombre_en_Lettre(colonne)).EntireColumn.AutoFit 'Ajuste la largeur au contenu

  Range("A1:" & Nombre_en_Lettre(colonne + 1) & "1").Select 'Pour régler le zoom de la page pour que sa rentre complètement
  ActiveWindow.Zoom = True

  Range("A1:A1").Select 'Pour se replacer de manière propre sur la feuille
'-------------
  Application.ScreenUpdating = True
  Set traiter = Nothing
End Sub
Function Nombre_en_Lettre(Nombre As Long) As String

If Nombre > 0 And Nombre < 257 Then
    Nombre_en_Lettre = Split(Cells(Nombre).Address, "$")(1)
Else
    Nombre_en_Lettre = Error(9)
End If

End Function

Private Sub bordures(traiter As Range, gauche As Integer, haut As Integer, bas As Integer, droit As Integer, Optional int_vertical As Integer, Optional int_horizontal As Integer)
   With traiter
     .Borders.LineStyle = xlContinuous
     .Borders.ColorIndex = 0
     .Borders.TintAndShade = 0
     .Borders(xlEdgeLeft).Weight = gauche
     .Borders(xlEdgeTop).Weight = haut
     .Borders(xlEdgeBottom).Weight = bas
     .Borders(xlEdgeRight).Weight = droit
     On Error Resume Next
     .Borders(xlInsideVertical).Weight = int_vertical
     .Borders(xlInsideHorizontal).Weight = int_horizontal
     On Error GoTo 0
   End With
End Sub

Private Sub couleurs(traiter As Range, couleur1 As Long, couleur2 As Long)
  With traiter.Interior
     .Pattern = xlPatternRectangularGradient
        .Gradient.RectangleLeft = 0.5
        .Gradient.RectangleRight = 0.5
        .Gradient.RectangleTop = 0.5
        .Gradient.RectangleBottom = 0.5
        .Gradient.ColorStops.Clear
      End With
      With traiter.Interior.Gradient.ColorStops.Add(0)
        .Color = couleur1
      End With
      With traiter.Interior.Gradient.ColorStops.Add(1)
        .Color = couleur2
      End With
End Sub

Observe également :
- plus un seul Goto là-dedans
- je ne passe pas des Ranges en paramètres, mais uniquement des chaînes les représentant. Cela me permet de gérer des erreurs aux ismissing éventuels
- cela ne veut pas dire que j'approuve
- il est fort vraisemblable que tu pourrais t'y prendre autrement qu'ainsi, mais là ... c'est toute ton appli, qu'il faudrait connaître.

________________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement vous dire ce qu'elle contient. Je n'interviendrai qu'en cas de nécessité de développ

Optimiser de code (procédure de mise en forme des données) [Résolu]

Votre réponse