Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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 !
 
Trier par date Trier par votes

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
 
Vote positif 0 Vote négatif

thunder23

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif

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.
 
Vote positif 0 Vote négatif

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.
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
A
  • Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
137
patricktoulon
  • Résolu(e)
Microsoft 365 VBA Insertion du numéro de semaine de manière dynamique
Réponses
11
Affichages
220
Etoto
  • Résolu(e)
XL 2021 Modification d'un code VBA
Réponses
5
Affichages
349
kiki29
H
  • Question
XL 2016 Mettre des titres avec une mise en forme spécifique
Réponses
1
Affichages
410
vgendron
D
  • Question
XL pour MAC [RESOLU]Cacher ou afficher colonnes, sauf colonne selectionné
Réponses
9
Affichages
914
Dudy
D
M
  • Question
Microsoft 365 VBA fusion défusion cellule gestion cellules
Réponses
8
Affichages
409
mix770
M
S
  • Question
Microsoft 365 créer un macro vba
Réponses
0
Affichages
352
souhaib ad
S
C
  • Résolu(e)
XL 2021 Macro pour mise en page
Réponses
11
Affichages
522
candido57
C
R
  • Question
XL 2016 Rendre plus lisible un code VBA
2
Réponses
23
Affichages
2 K
TooFatBoy
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…