XL 2010 Alléger et rendre plus rapide un code VBA

thunder23 · 5 Décembre 2019

Bonjour le forum,

Étant novice dans le codage en VBA je souhaiterais savoir comment alléger son code et le rendre plus rapide en exécution car j'ai créer un planning pour mon travail et en taille de fichier il est très volumineux et l'exécution de ma macro est un peu lente.
Voici le code code que je souhaiterais déjà alléger:

VB:

Sub generer_calendrier() 'Programme de création et mise en forme du calendrier
    
    Application.EnableEvents = False 'Désactivation fenêtre avertissement pour nombre de poste
    Application.ScreenUpdating = False
    
    annee = SpinButton_annee
    
    'Suppression
        Range("A10:BH40").ClearContents
        Range("F38:J38").Borders.LineStyle = Range("M6").Borders.LineStyle
        Range("F38:J38").Interior.Color = Range("M6").Interior.Color
        Range("A9:BH9").ClearComments 'Effacer commentaire sur Feuille GTA
        Range("D9,E9,I9,J9,N9,O9,S9,T9,X9,Y9,AC9,AD9,AH9,AI9,AM9,AN9,AR9,AS9,AW9,AX9,BB9,BC9,BG9,BH9").ClearContents 'Efface suivis mensuel
        Feuil8.Range("A3:IV2000").ClearContents 'Permet d'effacer les commentaires sur la feuille BDD_Call
    
    
    'Boucle MOIS
    For mois = 1 To 12
    
        nb_jours = Day(DateSerial(annee, mois + 1, 1) - 1)
        colonne = mois * 5 - 4
                
        'Boucle JOURS
        For jour = 1 To nb_jours
            
            date_du_jour = DateSerial(annee, mois, jour)
            cells(jour + 9, colonne) = date_du_jour
            
       'Couleur de fond pour cellule
            
            cells(jour + 9, colonne).Interior.Color = RGB(204, 255, 204)
            cells(jour + 9, colonne + 1).Interior.Color = RGB(204, 255, 204)
            cells(jour + 9, colonne + 2).Interior.Color = RGB(204, 255, 204)
            cells(jour + 9, colonne + 3).Interior.Color = RGB(204, 255, 204)
            cells(jour + 9, colonne + 4).Interior.Color = RGB(235, 241, 222)
            
        'Couleur texte Weekend
        If Weekday(date_du_jour) = 1 Or Weekday(date_du_jour) = 1 Then 'Coloration texte en rouge si dimanche
            
            cells(jour + 9, colonne).Font.Color = RGB(255, 0, 0)
        
        Else
            
            cells(jour + 9, colonne).Font.Color = RGB(0, 0, 0)
        
        End If
    
        'BORDURES
            'Gauche
            With cells(jour + 9, colonne).Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlMedium
            End With
            
            'Bas Ligne
            With cells(jour + 9, colonne).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlHairline
            End With
            With cells(jour + 9, colonne + 1).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlHairline
            End With
            With cells(jour + 9, colonne + 2).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlHairline
            End With
            With cells(jour + 9, colonne + 3).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlHairline
            End With
            With cells(jour + 9, colonne + 4).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlHairline
            End With
            If Weekday(date_du_jour) = 1 Then 'Si dimanche
                With cells(jour + 9, colonne).Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .Color = RGB(255, 0, 0)
                    .Weight = xlThin
                End With
                With cells(jour + 9, colonne + 1).Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .Color = RGB(255, 0, 0)
                    .Weight = xlThin
                End With
                With cells(jour + 9, colonne + 2).Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .Color = RGB(255, 0, 0)
                    .Weight = xlThin
                End With
                With cells(jour + 9, colonne + 3).Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .Color = RGB(255, 0, 0)
                    .Weight = xlThin
                End With
                With cells(jour + 9, colonne + 4).Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .Color = RGB(255, 0, 0)
                    .Weight = xlThin
                End With
            End If
            
            If jour = nb_jours Then 'Ligne bas du calendrier
                With cells(jour + 9, colonne).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlMedium
                End With
                With cells(jour + 9, colonne + 1).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlMedium
                End With
                With cells(jour + 9, colonne + 2).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlMedium
                End With
                With cells(jour + 9, colonne + 3).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlMedium
                End With
                With cells(jour + 9, colonne + 4).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlMedium
                End With
            End If
            
            'Droite
            If mois = 12 Or jour > 28 Then
            
            With cells(jour + 9, colonne + 4).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Color = RGB(0, 0, 0)
                .Weight = xlMedium
            End With
            End If
            
            'Affichage des données
            If derniere_ligne > 1 Then 'Si BD non vide
    
        For i = 0 To UBound(tab_bdd, 1)
            
            If tab_bdd(i, 0) = date_du_jour Then
            
            cells(jour + 9, colonne + 4) = tab_bdd(i, 1)
            
            no_couleur = tab_bdd(i, 3)
            
            If no_couleur = 0 Then
                cells(jour + 9, colonne + 4).Interior.Color = RGB(250, 255, 63)
            ElseIf no_couleur = 1 Then
                cells(jour + 9, colonne + 4).Interior.Color = RGB(91, 224, 255)
            ElseIf no_couleur = 2 Then
                cells(jour + 9, colonne + 4).Interior.Color = RGB(91, 255, 95)
            Else
                cells(jour + 9, colonne + 4).Interior.Color = RGB(255, 255, 255)
            End If
            
            End If
        
        Next
        
        End If
              
        Next
    
    Next

    Application.EnableEvents = True 'Réactivation fenêtre avertissement pour nombre de poste

End Sub
Private Sub SpinButton_annee_Change() 'Bouton pour changement d'année
    
        Label_annee.Caption = SpinButton_annee.Value
        generer_calendrier
 
End Sub

Merci d'avance pour vos conseils !

Staple1600 · 5 Décembre 2019

Bonsoir le fil, thunder23

Une petit cure d’allègement et une exécution plus rapide.
Reste à peaufiner le rendu final

VB:

Sub Calendrier()
Dim X&, i&, cal As Range, cell As Range, col, Z&
ANNEE = InputBox("Choisir l'année du calendrier?", "Calendrier", Year(Date))
Application.ScreenUpdating = False
FD = CDate("1/1/" & ANNEE): [A10] = FD: [A10:L4].DataSeries 1, 3, 3, 1
For i = 1 To 12
X = Day(DateSerial(Year(Cells(10, i)), Month(Cells(10, i)) + 1, 0))
With Cells(10, i).Resize(X)
.DataSeries 2, 3, 1, 1: .Interior.Color = 13434828
End With
Next
Range("A10:L40").SpecialCells(2, 1).Borders(xlEdgeBottom).Weight = xlHairline
Range("A10:L40").SpecialCells(2, 1).Borders(xlInsideHorizontal).Weight = xlHairline
Range("H10:H40").SpecialCells(2, 1).BorderAround 1, xlMedium
Range("G10:H40,A10:L40,H10:H40").SpecialCells(2, 1).BorderAround 1, xlMedium
MFC
'insertion colonnes (décommentez pour tester)
'col = Array("L:O", "K:N", "J:M", "I:L", "H:K", "G:J", "F:I", "E:H", "D:G", "C:F", "B:E")
'For Z = LBound(col) To UBound(col): Columns(col(Z)).Insert Shift:=xlToRight: Next
End Sub
Private Sub MFC()
Range("A10:L40").FormatConditions.Delete
Range("A10:L40").FormatConditions.Add Type:=xlExpression, Formula1:="=JOURSEM(A10;2)=7"
Range("A10:L40").FormatConditions(1).Font.Color = vbRed
With Range("A10:L40").FormatConditions(1).Borders(xlBottom)
.LineStyle = 1: .Color = vbRed: .Weight = xlHairline
End With
End Sub

thunder23 · 6 Décembre 2019

Bonsoir Staple1600,

Je viens d'essayer le code dans mon fichier et ça me met en debogage signifiant que les cellules fusionnées doivent être identique....

Voici le fichier en question mais en liens car ça me note qu'il est trop volumineux...

http://lameteo23.000webhostapp.com/Planning.zip

Cordialement

Staple1600 · 6 Décembre 2019

Bonsoir le fil

Désolé, j'ai oublié de préciser qu'il fallait tester mon code sur un classeur vierge
(Pour constater la différence de vitesse d’exécution)

thunder23 · 6 Décembre 2019

Bonsoir le fil,

Ah d'accord ok, je viens de faire l'essai et effectivement la vitesse est incomparable !
Par contre c'est pour l'adapter qui va être chaud car certaines variable me sont inconnu...

cdlt

Staple1600 · 6 Décembre 2019

Re

Ce qui est inconnu ne demande qu'a être connu

Il suffit de poser des questions
(ou de pratiquer l'art du clic-droit -> Rechercher avec le moteur...

)

Au départ, c'est un code que j'avais posté jadis dans un autre fil pour créer un simple calendrier.

Staple1600 · 6 Décembre 2019

Re

En relisant mon code, je me suis aperçu qu'il y avait des variables "scories"
(sans doute issues d'un vieux copier/coller)
Donc voici, une version toilettée
(plus ou moins proche de celle initialement jadis postée)

VB:

Public pg As Range
Sub Calendrier_B()
Dim x&, i&
ANNEE = InputBox("Choisir l'année du calendrier?", "Calendrier", Year(Date))
Application.ScreenUpdating = 0: Set pg = Range("A11:L41"): [A10].Font.Bold = -1
FD = CDate("1/1/" & ANNEE): [A11] = FD: [A11:L41].DataSeries 1, 3, 3, 1
[A10] = FD: [A10].AutoFill [A10:L10], 7: [A10:L10].NumberFormat = "mmmm"
For i = 1 To 12
x = Day(DateSerial(Year(Cells(11, i)), Month(Cells(11, i)) + 1, 0))
Cells(11, i).Resize(x).DataSeries 2, 3, 1, 1: Cells(11, i).Resize(x).Borders.Weight = 2
Next
pg.FormatConditions.Add 2, Formula1:="=JOURSEM(A11;2)>5": pg.FormatConditions(1).Font.Color = vbRed
End Sub

Dans cette version, la MFC signale les week-ends.

Staple1600 · 7 Décembre 2019

Re

En relisant ce que je viens de relire, je me suis rendu compte qu'on pouvait encore alléger un peu la chose.

VB:

Public pg As Range
Sub Calendrier_C()
Dim x&, i&
ANNEE = InputBox("Choisir l'année du calendrier?", "Calendrier", Year(Date))
Application.ScreenUpdating = 0
Set pg = [A11:L41]: [A10].Font.Bold = -1: [A10].NumberFormat = "mmmm"
[A10:A11] = CDate("1/1/" & ANNEE): [A10:L11].DataSeries 1, 3, 3, 1
For i = 1 To 12
x = Day(DateSerial(Year(Cells(11, i)), Month(Cells(11, i)) + 1, 0))
Cells(11, i).Resize(x).DataSeries 2, 3, 1, 1: Cells(11, i).Resize(x).Borders.Weight = 2
Next
pg.FormatConditions.Add 2, Formula1:="=JOURSEM(A11;2)>5": pg.FormatConditions(1).Font.Color = vbRed
End Sub

thunder23 · 7 Décembre 2019

Bonjour Staple1600,

Ah ça pour être plus allégé il y est ! va falloir que je comprenne le code mais le seul bémol c'est que le calendrier n'a plus de colonne vide entre les mois. Est-ce que je peux changer l'InputBox par un Label ou une Texbox?

cdlt

Staple1600 · 7 Décembre 2019

Bonjour le fil, thunder23

Tu peux faire ce que tu veux de ce code.
(sauf évidemment caler une armoire bancale avec

)

Les colonnes vides, tu les as avec la version du message#2

Sauf qu'il reste le boulot de finition.

Quand à l'explication du code, si tu as des questions sur telle ou telle syntaxe VBA.
N'hésites pas , je ne suis pas payé pour cela

thunder23 · 12 Décembre 2019

Bonsoir le fil, Staple1600

Est-ce que tu pourrais me dire comment je peux modifier la coloration du week-end car je pensais qu'en modifiant le code
"=JOURSEM(A11;2)>5"
je n'avais qu'à mettre 6 pour n'avoir que les diamanche de rouge mais sans succès.

Merci

Cdlt

Effectuez une recherche sur Excel Downloads...

XL 2010 Alléger et rendre plus rapide un code VBA

thunder23

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

thunder23

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

thunder23

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

thunder23

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

thunder23

XLDnaute Occasionnel

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums