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

thunder23

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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
 

Staple1600

XLDnaute Barbatruc
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

XLDnaute Barbatruc
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

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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
 

Statistiques des forums

Discussions
311 725
Messages
2 081 945
Membres
101 849
dernier inscrit
florentMIG