Calendrier Dynamique - Réduction temps macro

Bonjour le forum,

Je cherche à réduire le temps d'exécution d'une macro qui me sert à charger un calendrier, voici le code :

Sub Charger_collab()
Dim nb As Integer
Application.ScreenUpdating = False ' Désactive l'actualisation de l'écran pendan l'éxécution de la macro
Application.Calculation = xlCalculationManual ' Désactive la calculation automatique
Application.DisplayStatusBar = False

On Error Resume Next ' Passe a la suite si erreur
Sheets("Calendrier").Rows("8:" & Rows.Count).Delete ' Supprime toutes les lignes en dessus de la ligne 7
Sheets("Calendrier").Range("A7").Resize(1, 4).ClearContents ' Efface le contenu des cellules A à D de la ligne 7

For nb = 2 To Sheets("DATA").Range("A" & Rows.Count).End(xlUp).Row ' Compte le nombre d'employé dans la feuille DATA
If Sheets("DATA").Cells(nb, 9).Value >= Sheets("Calendrier").Range("E5").Value Then ' Si la date de sortie est égal ou inférieur au premier jour du mois affiché alors :
    If Sheets("DATA").Cells(nb, 8).Value <= Sheets("Calendrier").Range("AC5").Value Then
        If Sheets("Calendrier").Range("A" & Rows.Count).End(xlUp).Value = "" Then ' Si la dernière ligne du calendrier est vide alors :
        Sheets("Calendrier").Range("A" & Rows.Count).End(xlUp).Resize(1, 4).Value = Sheets("Data").Range("A" & nb).Resize(1, 4).Value ' Insère les données dans le calendrier
        Else
        ' Sinon colle les données copié une ligne de plus
        Sheets("Calendrier").Range("A" & Rows.Count).End(xlUp).Resize(1, 4).Offset(1).Value = Sheets("Data").Range("A" & nb).Resize(1, 4).Value
        End If
    End If
End If
Next nb ' Passe au prochain employé (Feuille DATA)

Call Interim ' Appel la macro intérim

Sheets("Calendrier").Range("A1").Select ' Selectionne la cellule A1
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic ' Active la calculation automatique
Application.ScreenUpdating = True ' Active l'actualisation à l'écran
End Sub

Je penses que ce code est relativement lent car il s'exécute cellule par cellule, mais après pas mal de tentative je n'ai pas trouvé un solution viable..

Quelqu'un pourrait-il m'aiguiller sur une méthode plus rapide ?

Merci,

Kilian

Bonjour,

Dans votre macro Interim, pour utilisez pour chaque valeur de la colonne A de la feuille DATA vous bouclez toutes les lignes de la feuille Calendrier

SI je comprends ce que vous voulez faire, c'est si la valeur YES est trouvée, colonne 10 en feuille DATA, vous grisez la ligne en fonction du numéro de matricule identique trouvé en colonne A. Juste ?
Si oui, en modifiant le code j'ai 4 secondes d'exécution

Hello Dan,

Oui c'est ça.

Donc en réalité c'est la mise en forme qui augmente le temps d'exécution.. Sur le calendrier que je vous ai joint, j'ai enlever pas mal de fonction et j'ai remarqué que j'ai également enlever une macro qui ajoute des bordures. Mais après test celle-ci rajoute 1 secondes à l'exécution de la macro...

Sur mon fichier original le temps de traitement monte jusqu'a 60 secondes. J'ai contrôler le temps des autres macro et ils ne rajoutent pas beaucoup de temps.

Avez-vous une autre alternative au mise en forme qui rajouterai du temps ?

Et est-ce que la macro charger_collab n'aura pas beaucoup d'influence sur un calendrier avec 1'000 lignes ?

Merci,

Kilian

Bonjour,

Beau fichier...

1. La macro Rafraichir ne me semble pas être pas un souci, bien qu'il y tout de même trois boucles imbriquées

2. Par rapport à mon post précédent vous pouvez remplacer la macro Interim par celle ci-dessous. On supprime la boucle for y= .....

Sub Interim()
Dim X As Integer, Y As Integer, lig As Integer
With Sheets("DATA")
    For X = 2 To .Range("A" & Rows.Count).End(xlUp).Row ' De la deuxième à la dernière ligne des matricules
        If .Cells(X, 10).Value = "Yes" Then
            On Error Resume Next
            lig = Sheets("Calendrier").Range("A7:A" & Range("A" & Rows.Count).End(xlUp).Row).Find(.Cells(X, 1), LookIn:=xlValues, lookat:=xlWhole).Row
            If lig > 0 Then Sheets("Calendrier").Cells(lig, 1).Resize(1, 4).Interior.Color = RGB(177, 179, 179)
        End If
    Next X
End With
End Sub

3. Evitez d'utiliser des noms d'instructions pour nommer les macros. Je vois notamment la macro INTERIOR. Appellez la plutot "RESETINTERIOR"

4. Supprimez la macro "TABL_GRAS" et remplacez la macro TABLEAU par celle ci-dessous

Sub TABLEAU()

Application.ScreenUpdating = False
Dim i As Byte

For i = 2 To 4
    With Sheets("Calendrier").ListObjects("Tableau2").ListColumns(i).DataBodyRange
        .BorderAround LineStyle:=xlContinuous
        .BorderAround ColorIndex:=0
        .BorderAround Weight:=xlMedium
    End With
Next i

Dim plage As Range
For i = 1 To 25 Step 5
    Set plage = Range(Sheets("Calendrier").ListObjects("Tableau2").ListColumns(i + 4).DataBodyRange, _
        Sheets("Calendrier").ListObjects("Tableau2").ListColumns(i + 8).DataBodyRange)
    With plage
        .BorderAround LineStyle:=xlContinuous
        .BorderAround ColorIndex:=0
        .BorderAround Weight:=xlMedium
    End With
Next i
Application.ScreenUpdating = True
End Sub

5. Je vais regarder la macro Charger_collab

Crdlt

Bonjour Dan,

Merci pour vos remarques, je vais essayer ça.

A+,

Kilian

re

Dans le code Charger_collab, dans boucle for nb=2 to Sheets("DATA") ..., juste en dessous de cette ligne

Sheets("Calendrier").Range("A7").Resize(1, 4).ClearContents

vous avez un IF que l'on peut supprimer. Les lignes pour la boucle deviennent ceci :

dlg = Sheets("Calendrier").Range("A" & Rows.Count).End(xlUp).Row
For nb = 2 To Sheets("DATA").Range("A" & Rows.Count).End(xlUp).Row ' Compte le nombre d'employé dans la feuille DATA
    If Sheets("DATA").Cells(nb, 9).Value >= Sheets("Calendrier").Range("E5").Value And _
        Sheets("DATA").Cells(nb, 8).Value <= Sheets("Calendrier").Range("AC5").Value Then

        Sheets("Calendrier").Range("A" & dlg).Resize(1, 4).Value = Sheets("Data").Range("A" & nb).Resize(1, 4).Value
        dlg = dlg + 1
    End If
Next nb

Sinon, essayez en changeant votre code par celui-ci dessous :

Sub Charger_collab()
Dim dlg As Integer, lig As Integer, nb As Integer
Dim j As Byte
Dim tablo()

Application.ScreenUpdating = False ' Désactive l'actualisation de l'écran pendan l'éxécution de la macro
Application.Calculation = xlCalculationManual ' Désactive la calculation automatique
Application.DisplayStatusBar = False

With Sheets("Calendrier")
    .Rows("8:" & Rows.Count).Delete ' Supprime toutes les lignes en dessus de la ligne 7
    .Range("A7").Resize(1, 4).ClearContents ' Efface le contenu des cellules A à D de la ligne 7
End With

dlg = Sheets("DATA").Range("A" & Rows.Count).End(xlUp).Row

ReDim tablo(dlg, 3)
j = 0
lig = 0

For nb = 2 To dlg

    If Sheets("DATA").Cells(nb, 9).Value >= Sheets("Calendrier").Range("E5").Value And _
        Sheets("DATA").Cells(nb, 8).Value <= Sheets("Calendrier").Range("AC5").Value Then

        For j = 0 To 3
            tablo(lig, j) = Sheets("DATA").Cells(nb, j + 1)
        Next j
        lig = lig + 1

    End If

Next nb

With Sheets("Calendrier")
    dlg = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("A" & dlg & ":D" & dlg).Resize(UBound(tablo) + 1) = tablo
End With

Call TABLEAU
Call Interim ' Appel la macro intérim

Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic ' Active la calculation automatique
Application.ScreenUpdating = True ' Active l'actualisation à l'écran

End Sub

A quoi vous servait le On error resume next ?

Si vous prenez la dernière proposition, cela devrait améliorer

Crdlt

Dan,

Merci pour cette solution, à laquelle je ne penses pas assez..

Tester et approuver, c'est déjà plus rapide.

Le On Error Resume Next ne me sert plus dans le code actuel, je l'avais mis dans une ancienne version et je ne l'avais pas enlever depuis.

Sujet désormais clos ! Merci pour l'intérêt porté à ma demande.

A+,

Kilian

Re

en fait je me suis trompé en postant le dernier code lorsque je vous disais "sinon, essayez en changeant le code..." (https://forum.excel-pratique.com/s/goto/974184)

Prenez donc le code Charger_collab dans mon post précédent puis refaite le test. Vous allez gagner en temps d'exécution

Crdlt

Hello Dan,

Je viens d'essayer le code corrigé que vous m'avez mis, et il se trouve que celui-ci me rajoute 2 à 3 lignes vident à la fin du calendrier.

Par contre effectivement le temps d'exécution est bien inférieur. J'imagine que ceci est dû au redimensionnement du tableau.

J'ai fait quelques test et je ne trouves pas le problème des lignes vident supplémentaire à la fin du calendrier, pouvez-vous encore m'aider ?

Merci, A+

Kilian

Bonjour,

Je viens d'essayer le code corrigé que vous m'avez mis, et il se trouve que celui-ci me rajoute 2 à 3 lignes vident à la fin du calendrier.

A la fin du code Charger_collab, changez

.Range("A" & dlg & ":D" & dlg).Resize(UBound(tablo) + 1) = tablo

par

.Range("A" & dlg & ":D" & dlg).Resize(UBound(tablo) - 1) = tablo

Crdlt

Dan,

Même avec ce changement, le redimensionnement du tableau ne se fait pas correctement.

Lorsque je change de mois/année, il se peut que certains collaborateurs se soient pas chargé en fonction de la date d'entrée/sortie. Le tableau reste dans la dimensions du premier mois chargé, ce qui affiche simplement vide si il y a un collaborateur en moins. De plus, le tableau indique en permanence une ligne supplémentaire.
Je réalise les test sur un fichier avec d'autres fonctions, dont un ajout de collaborateurs par un userform, qui active la macro, à l'activation de celle-ci, une ligne vient se rajouter au tableau, mais aucune donnée ne s'affiche.

A+,

Kilian

Donnez moi un exemple car si dans votre fichier je rajoute une ligne avec le matricule 371 en feuille DATA ou que par exemple j'en supprime deux, le calendrier est adapté

Je pense que vous faite des tests sur un autre fichier car dans celui que vous avez posté, le code s'arrête car toutes les variables ne sont pas définies dans la Sub Fériés()

Dan,

Voici un fichier avec la majorité des fonctions active. J'ai volontairement laisser des absences visibles pour se rendre compte du fonctionnement.

Vous verrez donc à la fin du calendrier, entre le mois de juin et juillet le dimensionnement ne se charge par correctement.

J'ai compris. en fait ces lignes vides viennent du fait que dans la feuille DATA, le code tient compte des dates de sortie.

Dans votre fichier initiale, toutes les dates étaient au 1/01/2099 tandis que dans votre dernier fichier et dans la réalité c'est tout autre.

A la fin du code Charger_collab, entre NEXT nb et CALL Tableau, remplacez les lignes par celles ci-dessous

Dim X
With Sheets("Calendrier")
    dlg = .Range("A" & .Rows.Count).End(xlUp).Row
    X = UBound(tablo) - lig
    .Range("A" & dlg & ":D" & dlg).Resize(UBound(tablo) - X) = tablo
End With

Refaite un test

NB :
- Attention que dans certaines macros de votre feuille calendrier, les variables Finalrow et X ne sont pas déclarées
- Toujours dans cette feuille la déclaration --> Dim WsN, WsC As Worksheet doit être comme ceci --> Dim WsN as Worksheet, WsC As Worksheet

- Dans d'autres macros aussi certaines variables ne sont pas déclarées. Pour être sûre qu'elles le sont mettez l'instruction Option Explicit en entete de tous les modules. cela vous permettra de vérifier

- Aussi évitez les accents dans le nom des macros, cela évite des soucis quelques fois.

Crdlt

Dan,

C'est tout bon, ça marche très bien. Effectivement dans la réalité les dates vont variées.

Je vais revoir toutes variables et remettre à jour avec option explicit par module afin d'avoir quelques choses de plus propres.

Merci beaucoup pour les réponses que vous m'avez apporté ainsi que vos remarques.

Sujet clos !

Meilleures salutations,

Kilian