Double Boucle VBA prend trop de temps

Bonjour,

Je dois transposer d'un onglet A vers un onglet B, les semaines de vacances posées par des employés sous un calendrier "horizontal" avec leur initiale sous le numéro de semaine correspondant. J'ai fait une copie d'écran d'une partie des onglets.

En exemple: Je dois avoir dans l'onglet B, sous la colonne correspondant au numéro de semaine x, toutes les initiales des personnes qui ont choisi d'être en congé cette semaine x. (en respectant une priorité de couleur Rouge/BleuFoncé/Jaune/BleuClair hors vacances scolaires et BleuFoncé/Rouge/BleuClair/Jaune pendant les vacances).

J'utilise donc une boucle qui sélectionne chaque case à remplir dans l'onglet B, une fois sélectionnée, j'ai deux boucles (la première sélectionne le bloc couleur en fonction des priorités et la deuxième passe chaque ligne de ce bloc). Chaque cellule est donc vérifiée pour voir si la valeur dans la cellule de l'onglet A correspond au numéro de semaine sélectionné sur l'onglet B et inscrit les initiales dans l'onglet B si c'est bon.

Ma solution fonctionne correctement, mais par contre j'ai un temps de compilation de 7min.....

Quelqu'un aurait une idée?

D'avance merci.

onglet b onglet a

Bonjour,

Imagine tu que l'on puisse vraiment t'aider à partir de 2 images de ton fichier et sans avoir à disposition le code VBA que tu as produit ?

Voici le code que j'utilise.

Je sais que c'est lourd comme méthode mais je ne suis pas calé pour faire mieux

'TRANSFER SEULEMENT DES VACANCES
Dim Ligne_Incrément As Integer
Dim Ligne_Debut As Integer
Dim Ligne_Fin As Integer
Dim Col_Initiale As Integer
Dim Nombre_ATCO As Integer
Dim Col_Num_Semaine As Integer
Dim Col_Couleur As Integer
Dim Col_Bleu As Integer
Dim Col_Bleuclair As Integer
Dim Col_Rouge As Integer
Dim Col_Jaune As Integer
Dim Col_Sup_Bleu As Integer
Dim Col_Sup_Gris As Integer
Dim Col_debut As Integer
Dim Col_fin As Integer
Dim Col_increment As Integer
Dim Nb_Vac_ATCO As Integer
Dim Nb_Vac_SPVR As Integer
Dim Col_Annuel_Increment As Integer
Dim Col_Annuel_Debut As Integer
Dim Col_Annuel_Fin As Integer
Dim Ligne_ATCO_Debut As Integer
Dim Ligne_ATCO_Increment As Integer
Dim Ligne_ATCO_Fin As Integer
Dim Ligne_SPVR_Debut As Integer
Dim Ligne_SPVR_Increment As Integer
Dim Ligne_SPVR_Fin As Integer
Dim Ligne_Annuel_Vacances As Integer
Dim Col_Annuel_Vacances As Integer
Dim Couleur_Sem_Annuel As Integer
Dim Couleur_Vacances_Officiel As String
Dim Initiale As String
Dim Col_Annuel As String
Dim i As String
Dim y As String
Dim Titre As String
Sub TransferVacances()
    If MsgBox("Etes-vous certain de vouloir supprimer et recharger les données saisies?", vbYesNo, "Demande de confirmation") = vbYes Then
    'On efface les données du tableau existant
    Set JUMBO = Worksheets("Jumbo")
    Set VACANCES = Worksheets("Holidays")
    Spvr_vacances = "C49:BF68"  'Plage de données des SPVR VACANCES
    Atco_vacances = "C80:BF121" 'Plage de données des ATCO VACANCES
    JUMBO.Range(Spvr_vacances).ClearContents
    JUMBO.Range(Spvr_vacances).ClearComments
    JUMBO.Range(Spvr_vacances).Interior.Color = xlNone
    JUMBO.Range(Atco_vacances).ClearContents
    JUMBO.Range(Atco_vacances).ClearComments
    JUMBO.Range(Atco_vacances).Interior.Color = xlNone
    'On compile les F_Isolés en "Numéro de semaines + commentaires"
    'Application.Run ("Commentaires")
    'Activation de la page Vacances
    VACANCES.Activate

    'Definition des différents numéro de colonne.
    Titre = "A1:AR1"
    Col_Initiale = Application.Match("Initiales", VACANCES.Range(Titre), 0)
    Col_Bleu = Application.Match("Bleu foncé", VACANCES.Range(Titre), 0)
    Col_Bleuclair = Application.Match("Bleu clair", VACANCES.Range(Titre), 0)
    Col_Rouge = Application.Match("Rouge", VACANCES.Range(Titre), 0)
    Col_Jaune = Application.Match("Jaune", VACANCES.Range(Titre), 0)
    Col_Sup_Bleu = Application.Match("Superviseurs Bleu", VACANCES.Range(Titre), 0)
    Col_Sup_Gris = Application.Match("Superviseurs Gris", VACANCES.Range(Titre), 0)

    'Compte le nombre de nom d'ATCO dans la colonne "Initiales"
    'Definition du début des lignes à tranférer sur la base de 140 ATCOS
    Ligne_Debut = 2 'Ligne correspondant au 1er nom ATCO
    Nombre_ATCO = WorksheetFunction.CountA(Range(Cells(Ligne_Debut, Col_Initiale), Cells(141, Col_Initiale)))
    Ligne_Fin = Ligne_Debut + Nombre_ATCO - (Ligne_Debut - 1) '-1 car on commence à la Ligne_Debut

    'Definition du début et de la fin du tableau sur l'onglet "JUMBO"
    Ligne_Annuel_Vacances = 11  'Ligne "Semaine N°"
    Col_Annuel_Vacances = 2     'Colonne "Semaine N°"
    Ligne_ATCO_Debut = 121      'Ligne "ATCO" Bottom
    Ligne_ATCO_Fin = 80         'Ligne "ATCO" Top
    Ligne_SPVR_Debut = 68       'Ligne "SPVR" Bottom
    Ligne_SPVR_Fin = 49         'Ligne "SPVR" Top
    Col_Annuel_Debut = 3        'Colonne "Semaine 1" de l'année
    Col_Annuel_Fin = Col_Annuel_Debut + 52         '52+1 semaines dont la 1ere colonne donc 52
    Col_Num_Semaine = Col_Annuel_Debut             'Semaine 1 commence à Col_Annuel_Debut

    Couleur_Vacances_Officiel = JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Vacances).Interior.Color 'Case "Semaine N°" dans "Jumbo"

    'Définition du nombre de choix de vacances/Fisolé possible
    Nb_Vac_ATCO = 3 '4 semaines mais on compte à partir de 0
    Nb_Vac_SPVR = 6 '7 semaines mais on compte à partir de 0

    'Initialisation des variables d'incrément pour chaque boucle
    Col_Annuel_Increment = Col_Annuel_Debut

    While Col_Annuel_Increment <= Col_Annuel_Fin
        If JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Increment).Interior.Color = Couleur_Vacances_Officiel Then
        'Sélection des vacances pendant la période des vacances scolaires
            y = 0
            While y <= 5
                'Définition de la 1ère ligne à sélectionner dans onglet "Vacances"
                Ligne_Increment = Ligne_Debut
                'Définition de la couleur de vacances sélectionnées
                If y = 0 Then
                    Col_Couleur = Col_Bleu
                ElseIf y = 1 Then
                    Col_Couleur = Col_Rouge
                ElseIf y = 2 Then
                    Col_Couleur = Col_Bleuclair
                ElseIf y = 3 Then
                    Col_Couleur = Col_Jaune
                ElseIf y = 4 Then
                    Col_Couleur = Col_Sup_Bleu
                ElseIf y = 5 Then
                    Col_Couleur = Col_Sup_Gris
                End If
                'Trie des vacances ATCO
                While Ligne_Increment <= Ligne_Fin And y <= 3
                    i = 0
                    While i <= Nb_Vac_ATCO
                        'On regarde si VACANCES posées = numéro de semaine
                        If VACANCES.Cells(Ligne_Increment, Col_Couleur + i) = 0 Or VACANCES.Cells(Ligne_Increment, Col_Couleur + i) > JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Increment) Then
                        i = Nb_Vac_ATCO
                        ElseIf VACANCES.Cells(Ligne_Increment, Col_Couleur + i) = JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Increment) Then
                            Initiale = VACANCES.Cells(Ligne_Increment, Col_Initiale)
                            Col_Num_Semaine = VACANCES.Cells(Ligne_Increment, Col_Couleur + i) + (Col_Annuel_Debut - 1)  'Car on commence à Col_Annuel_Debut dans le tableau "Jumbo"
                            Ligne_ATCO_Increment = Ligne_ATCO_Debut
                            While Ligne_ATCO_Increment >= Ligne_ATCO_Fin
                                If JUMBO.Cells(Ligne_ATCO_Increment, Col_Num_Semaine) = 0 Then
                                    JUMBO.Cells(Ligne_ATCO_Increment, Col_Num_Semaine) = Initiale
                                    JUMBO.Cells(Ligne_ATCO_Increment, Col_Num_Semaine).Interior.Color = VACANCES.Cells(Ligne_Debut - 1, Col_Couleur).Interior.Color
                                    Ligne_ATCO_Increment = 0
                                Else
                                    'On passe à la ligne d'avant
                                    Ligne_ATCO_Increment = Ligne_ATCO_Increment - 1
                                End If
                            Wend
                        End If
                        'On passe à la colonne d'après
                        i = i + 1
                    Wend
                    'On passe à la ligne d'après
                    Ligne_Increment = Ligne_Increment + 1
                Wend
                'Trie des vacances SPVR
                While Ligne_Increment <= Ligne_Fin And y >= 4 And y <= 5
                    i = 0
                    While i <= Nb_Vac_SPVR
                        'On regarde si VACANCES posées = numéro de semaine
                        If VACANCES.Cells(Ligne_Increment, Col_Couleur + i) = 0 Or VACANCES.Cells(Ligne_Increment, Col_Couleur + i) > JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Increment) Then
                            i = Nb_Vac_SPVR
                        ElseIf VACANCES.Cells(Ligne_Increment, Col_Couleur + i) = JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Increment) Then
                            Initiale = VACANCES.Cells(Ligne_Increment, Col_Initiale)
                            Col_Num_Semaine = VACANCES.Cells(Ligne_Increment, Col_Couleur + i) + (Col_Annuel_Debut - 1)  'Car on commence à Col_Annuel_Debut dans le tableau "Jumbo"
                            Ligne_SPVR_Increment = Ligne_SPVR_Debut
                            While Ligne_SPVR_Increment >= Ligne_SPVR_Fin
                                If JUMBO.Cells(Ligne_SPVR_Increment, Col_Num_Semaine) = 0 Then
                                    JUMBO.Cells(Ligne_SPVR_Increment, Col_Num_Semaine) = Initiale
                                    JUMBO.Cells(Ligne_SPVR_Increment, Col_Num_Semaine).Interior.Color = VACANCES.Cells(Ligne_Debut - 1, Col_Couleur).Interior.Color
                                    Ligne_SPVR_Increment = 0
                                Else
                                    'On passe à la ligne d'avant
                                    Ligne_SPVR_Increment = Ligne_SPVR_Increment - 1
                                End If
                            Wend
                        End If
                        'On passe à la colonne d'après
                        i = i + 1
                    Wend
                    'On passe à la ligne d'après
                    Ligne_Increment = Ligne_Increment + 1
                Wend
            y = y + 1
            Wend
        Else
        'Sélection des vacances hors de la période des vacances scolaires
            y = 0
            While y <= 5
                'Définition de la 1ère ligne à sélectionner dans onglet "Vacances"
                Ligne_Increment = Ligne_Debut
                'Définition de la couleur de vacances sélectionnées
                If y = 0 Then
                    Col_Couleur = Col_Rouge
                ElseIf y = 1 Then
                    Col_Couleur = Col_Bleu
                ElseIf y = 2 Then
                    Col_Couleur = Col_Jaune
                ElseIf y = 3 Then
                    Col_Couleur = Col_Bleuclair
                ElseIf y = 4 Then
                    Col_Couleur = Col_Sup_Gris
                ElseIf y = 5 Then
                    Col_Couleur = Col_Sup_Bleu
                End If
                'Trie des vacances ATCO
                While Ligne_Increment <= Ligne_Fin And y <= 3
                    i = 0
                    While i <= Nb_Vac_ATCO
                        'On regarde si VACANCES posées = numéro de semaine
                        If VACANCES.Cells(Ligne_Increment, Col_Couleur + i) = 0 Or VACANCES.Cells(Ligne_Increment, Col_Couleur + i) > JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Increment) Then
                            i = Nb_Vac_ATCO
                        ElseIf VACANCES.Cells(Ligne_Increment, Col_Couleur + i) = JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Increment) Then
                            Initiale = VACANCES.Cells(Ligne_Increment, Col_Initiale)
                            Col_Num_Semaine = VACANCES.Cells(Ligne_Increment, Col_Couleur + i) + (Col_Annuel_Debut - 1)  'Car on commence à Col_Annuel_Debut dans le tableau "Annuel"
                            Ligne_ATCO_Increment = Ligne_ATCO_Debut
                            While Ligne_ATCO_Increment >= Ligne_ATCO_Fin
                                If JUMBO.Cells(Ligne_ATCO_Increment, Col_Num_Semaine) = 0 Then
                                    JUMBO.Cells(Ligne_ATCO_Increment, Col_Num_Semaine) = Initiale
                                    JUMBO.Cells(Ligne_ATCO_Increment, Col_Num_Semaine).Interior.Color = Cells(Ligne_Debut - 1, Col_Couleur).Interior.Color
                                    Ligne_ATCO_Increment = 0
                                Else
                                    'On passe à la ligne d'avant
                                    Ligne_ATCO_Increment = Ligne_ATCO_Increment - 1
                                End If
                            Wend
                        End If
                        'On passe à la colonne d'après
                        i = i + 1
                    Wend
                    'On passe à la ligne d'après
                    Ligne_Increment = Ligne_Increment + 1
                Wend
                'Trie des vacances SPVR
                While Ligne_Increment <= Ligne_Fin And y >= 4 And y <= 5
                    i = 0
                    While i <= Nb_Vac_SPVR
                        'On regarde si VACANCES posées = numéro de semaine
                        If VACANCES.Cells(Ligne_Increment, Col_Couleur + i) = 0 Or VACANCES.Cells(Ligne_Increment, Col_Couleur + i) > JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Increment) Then
                            i = Nb_Vac_SPVR
                        ElseIf VACANCES.Cells(Ligne_Increment, Col_Couleur + i) = JUMBO.Cells(Ligne_Annuel_Vacances, Col_Annuel_Increment) Then
                            Initiale = VACANCES.Cells(Ligne_Increment, Col_Initiale)
                            Col_Num_Semaine = VACANCES.Cells(Ligne_Increment, Col_Couleur + i) + (Col_Annuel_Debut - 1)  'Car on commence à Col_Annuel_Debut dans le tableau "Annuel"
                            Ligne_SPVR_Increment = Ligne_SPVR_Debut
                            While Ligne_SPVR_Increment >= Ligne_SPVR_Fin
                                If JUMBO.Cells(Ligne_SPVR_Increment, Col_Num_Semaine) = 0 Then
                                    JUMBO.Cells(Ligne_SPVR_Increment, Col_Num_Semaine) = Initiale
                                    JUMBO.Cells(Ligne_SPVR_Increment, Col_Num_Semaine).Interior.Color = Cells(Ligne_Debut - 1, Col_Couleur).Interior.Color
                                    Ligne_SPVR_Increment = 0
                                Else
                                    'On passe à la ligne d'avant
                                    Ligne_SPVR_Increment = Ligne_SPVR_Increment - 1
                                End If
                            Wend
                        End If
                        'On passe à la colonne d'après
                        i = i + 1
                    Wend
                    'On passe à la ligne d'après
                    Ligne_Increment = Ligne_Increment + 1
                Wend
            y = y + 1
            Wend
        End If
        Col_Annuel_Increment = Col_Annuel_Increment + 1
    Wend
    'Activation de la page Annuel
    JUMBO.Activate
    Application.Run ("Miseajour_SPVR")
    End If
End Sub

Bonjour,

Imagine tu que l'on puisse vraiment t'aider à partir de 2 images de ton fichier et sans avoir à disposition le code VBA que tu as produit ?

J'étais en train de le faire

Tente en ajoutant :

- En début de macro :

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

- En fin de macro :

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Du génie

Merci.

En fait cela stop tous les calculs de la page pendant l'éxécution de la macro, c'est ça?e

Du génie

Merci.

En fait cela stop tous les calculs de la page pendant l'éxécution de la macro, c'est ça?e

Excel réévalue par défaut toutes les fonctions d'un classeur à chaque modification, afin de faire évoluer leur résultat dans le cas où une modification affecte une ou plusieurs formules. Evidemment, cette opération peut s'avérer gourmande quand tu as beaucoup d'éléments à réévaluer et quand c'est fait de façon répétée au beau milieu de l'exécution d'une macro. Il s'agit donc de désactiver ceci le temps d'exécuter la macro.

Merci beaucoup

Merci beaucoup

Je suppose que ça a fonctionné ?

Rechercher des sujets similaires à "double boucle vba prend trop temps"