Macro tres lente

bonjour , je voudrais avoir votre avis sur une macro qui me rend les calcul lents, j'ai mit les petits astuces pour améliorer mais toujours la même résultats ,c'est une macro pour détecter les doublons sur un tableau de bord ,voila le code et merci d'avance :

Sub Prov()

Dim shtJT As Worksheet 
Dim rf1 As Range 'déclare la variable pf (Plage de référence)
Dim rf2 As Range 'déclare la variable pf (Plage de référence)
Dim rf3 As Range 'déclare la variable pf (Plage de référence)
Dim rf4 As Range 'déclare la variable pf (Plage de référence)
Dim rf5 As Range 'déclare la variable pf (Plage de référence)
Dim rc1 As Range 'déclare la variable pr (Plage de Recherche)
Dim rc2 As Range 'déclare la variable pr (Plage de Recherche)
Dim rc3 As Range 'déclare la variable pr (Plage de Recherche)
Dim rc4 As Range 'déclare la variable pr (Plage de Recherche)
Dim rc5 As Range 'déclare la variable pr (Plage de Recherche)
Dim cf As Range 'déclare la variable cf (Cellule de la plage de référence)
Dim cr As Range 'déclare la variable cr (Cellule de la plage de Recherche)

Application.ScreenUpdating = False
Application.Calculation = xlManual

       Set shtJT = ActiveWorkbook.ActiveSheet

       With shtJT
                Set rf1 = .Range("D1:F19")
                Set rf2 = .Range("G1:I19")
                Set rf3 = .Range("J1:L19")
                Set rf4 = .Range("M1:O19")
                Set rf5 = .Range("P1:R19")
                Set rc1 = .Range("D25:F300") 
                Set rc2 = .Range("G25:I300")
                Set rc3 = .Range("J25:L300")
                Set rc4 = .Range("M25:O300")
                Set rc5 = .Range("P25:R300")

                For Each cf In rf1 'boucle 1 : sur toutes les cellules cf de la plage pf1
                    For Each cr In rc1 'boucle 2 : sur toutes les cellules cr de la plage rc1

                         If cr.Value = cf.Value Then  'condition : si les deux cellules sont identiques
                            cf.Font.ColorIndex = 2
                            Exit For
                            Else: cf.Font.ColorIndex = 1
                       End If 'fin de la condition

                 Next cr 'prochaine cellule cr de la boucle 2
                Next cf 'prochaine cellule cf de la boucle 1

               For Each cf In rf2 
                    For Each cr In rc2 

                         If cr.Value = cf.Value Then  
                            cf.Font.ColorIndex = 2
                            Exit For
                            Else: cf.Font.ColorIndex = 1
                       End If 

                 Next cr 'prochaine cellule cr de la boucle 2
                Next cf 'prochaine cellule cf de la boucle 1

                For Each cf In rf3 
                    For Each cr In rc3 

                         If cr.Value = cf.Value Then  

                            cf.Font.ColorIndex = 2
                            Exit For
                            Else: cf.Font.ColorIndex = 1
                       End If 

                 Next cr 
                Next cf 

                For Each cf In rf4 
                    For Each cr In rc4 

                         If cr.Value = cf.Value Then  

                            cf.Font.ColorIndex = 2
                            Exit For
                            Else: cf.Font.ColorIndex = 1
                       End If 

                 Next cr 
                Next cf 

                For Each cf In rf5 
                    For Each cr In rc5 

                         If cr.Value = cf.Value Then  
                            cf.Font.ColorIndex = 2
                            Exit For
                            Else: cf.Font.ColorIndex = 1
                       End If 

                 Next cr 
                Next cf 

            End With 

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

End Sub

Bonjour yassinearhezroq, bonjour le Forum,

J'ai une première piste pour toi, au lieu d'utiliser "set range", il te serait préférable de tout stocker dans un tableau VBA puis de faire la comparaison directement dans ton tableau avec les boucles!

Si tu peux me faire un extract de la page sur laquelle fonctionne ta macro et me la mettre en PJ (quitte a mettre de fausses données dedans) je pourrait éventuellement retoucher ta macro sans faire d'erreur!

Au plaisir de te lire,

Yann

Bonjour Yann,

Merci pour ton Aide , tu trouveras en PJ un exemple du Tableau de bord .

Je te remercie, je reviens vers toi avec une macro ASAP!

J'ai une autre piste qui expliquerai que ta macro soit lente, c'est le fait de retoucher la couleur du texte des cellules (l'idée c'est que VBA doit interagir le moins possible avec tes feuilles).

A la place de mettre le texte de tes cellules en blanc, ne serait-il pas possible de simplement supprimer leur contenu? Là tu gagnerai vraiment en rapidité!

Edit: Je remarque d'ailleurs que les valeurs des plages de références sont toujours les même, et classées dans l'ordre croissant, c'est toujours le cas?

Oui , tu as raison , j'ai essayer cette méthode mais parfois on peut supprimer une cellule avec la fonction mais la plage de recherche ne sera plus valable a mon avis pour chercher , on est obliger de réinitialiser , sinon il faut extrait la liste du tableau de bord et ca j'ai pas essayer

Merci encore une fois

On reprend, j'ai pas tout compris!

Dans les plages de références, est ce que les valeurs sont le résultat de formules inscrites dans les cellules?

- > Par exemple, sur le fichier que tu as mis en PJ, la Cellule D1 = 1, ce n'est pas le résultat d'une formule.

Si les valeurs ne sont pas les résultats de formules, est ce que ce sont toujours les mêmes?

- > Sur ton fichier, la cellule D1 = G1 = J1, est-ce toujours le cas?

Et sont-elle toujours rangées dans un ordre croissant?

-> Sur ton fichier, D2 = D1 + 1 , D3 = D2+1 etc

Bref, c'était peut être juste pour l'exemple que les valeurs sont comme ça, mais dans le doute je te demande parce que ça pourrait vraiment changer la vitesse d'exécution de ton code!

oui c'est vrais que j'ai pas bien expliquer , si tu as remarquer que pour chaque jour il faut faire la comparaison des données et la liste ( c'est une liste des noms avec des textes , moi j'ai mit des nombre pour l'exemple) et la liste est la même pour tout les jours , mais par contre les données de chaque jours peuvent êtres différentes , pour l'ordre c'est pas important les données de chaque jour peuvent être aléatoire .

Ok, bon dans le doute, voilà ta macro en retour! Elle fonctionne exactement comme la tienne, sauf qu'on passe par des tableaux au lieu de travailler sur la feuille!

Si tu as des questions, n'hésites pas!

Sub Prov()

Dim rf1(18, 2) As Variant 'déclare la variable pf (Plage de référence)
Dim rf2(18, 2) As Variant 'déclare la variable pf (Plage de référence)
Dim rf3(18, 2) As Variant 'déclare la variable pf (Plage de référence)
Dim rf4(18, 2) As Variant 'déclare la variable pf (Plage de référence)
Dim rf5(18, 2) As Variant 'déclare la variable pf (Plage de référence)

Dim rc1(275, 2) As Variant 'déclare la variable pr (Plage de Recherche)
Dim rc2(275, 2) As Variant  'déclare la variable pr (Plage de Recherche)
Dim rc3(275, 2) As Variant 'déclare la variable pr (Plage de Recherche)
Dim rc4(275, 2) As Variant 'déclare la variable pr (Plage de Recherche)
Dim rc5(275, 2) As Variant 'déclare la variable pr (Plage de Recherche)

Dim tableau_recup_data As Variant
Dim i As Long, j As Long, u As Long, v As Long
Dim colorertexte As Boolean

'Recupération en un coup des data de la page
tableau_recup_data = ActiveWorkbook.ActiveSheet.Range("D1:R300").Value

'On désactive le rafraichissement de l'écran, le calcul automatique et les évenements
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'Remplissage des tableaux vba de référence

For i = 0 To 18
    For j = 0 To 2

    rf1(i, j) = tableau_recup_data(i + 1, j + 1)
    rf2(i, j) = tableau_recup_data(i + 1, j + 4)
    rf3(i, j) = tableau_recup_data(i + 1, j + 7)
    rf4(i, j) = tableau_recup_data(i + 1, j + 10)
    rf5(i, j) = tableau_recup_data(i + 1, j + 13)

     Next j
Next i

'Remplissage des tableaux vba de recherche

For i = 0 To 275
    For j = 0 To 2

    rc1(i, j) = tableau_recup_data(i + 25, j + 1)
    rc2(i, j) = tableau_recup_data(i + 25, j + 4)
    rc3(i, j) = tableau_recup_data(i + 25, j + 7)
    rc4(i, j) = tableau_recup_data(i + 25, j + 10)
    rc5(i, j) = tableau_recup_data(i + 25, j + 13)

    Next j
Next i

'Comparaison

'On boucle sur toutes les cellules du tableau de référence 1
For i = 0 To 18
    For j = 0 To 2
    colorertexte = False 'On place un capteur qui se déclenchera au cas ou des valeur sont égales

    For u = 0 To 275
    If rf1(i, j) = rc1(u, 0) Or rf1(i, j) = rc1(u, 1) Or rf1(i, j) = rc1(u, 2) Then colorertexte = True 'Les valeurs sont égales, on declenche le capteur
    Next u

    If colorertexte = True Then 'On vérifie que le capteur se soit déclenché
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 4 + j).Font.ColorIndex = 2
    Else
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 4 + j).Font.ColorIndex = 1
    End If

    Next j
Next i

'On boucle sur toutes les cellules du tableau de référence 2
For i = 0 To 18
    For j = 0 To 2
    colorertexte = False 'On place un capteur qui se déclenchera au cas ou des valeur sont égales

    For u = 0 To 275
    If rf2(i, j) = rc2(u, 0) Or rf2(i, j) = rc2(u, 1) Or rf2(i, j) = rc2(u, 2) Then colorertexte = True 'Les valeurs sont égales, on declenche le capteur
    Next u

    If colorertexte = True Then 'On vérifie que le capteur se soit déclenché
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 7 + j).Font.ColorIndex = 2
    Else
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 7 + j).Font.ColorIndex = 1
    End If

    Next j
Next i

'On boucle sur toutes les cellules du tableau de référence 3
For i = 0 To 18
    For j = 0 To 2
    colorertexte = False 'On place un capteur qui se déclenchera au cas ou des valeur sont égales

    For u = 0 To 275
    If rf3(i, j) = rc3(u, 0) Or rf3(i, j) = rc3(u, 1) Or rf3(i, j) = rc3(u, 2) Then colorertexte = True 'Les valeurs sont égales, on declenche le capteur
    Next u

    If colorertexte = True Then 'On vérifie que le capteur se soit déclenché
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 10 + j).Font.ColorIndex = 2
    Else
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 10 + j).Font.ColorIndex = 1
    End If

    Next j
Next i

'On boucle sur toutes les cellules du tableau de référence 4
For i = 0 To 18
    For j = 0 To 2
    colorertexte = False 'On place un capteur qui se déclenchera au cas ou des valeur sont égales

    For u = 0 To 275
    If rf4(i, j) = rc4(u, 0) Or rf4(i, j) = rc4(u, 1) Or rf4(i, j) = rc4(u, 2) Then colorertexte = True 'Les valeurs sont égales, on declenche le capteur
    Next u

    If colorertexte = True Then 'On vérifie que le capteur se soit déclenché
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 13 + j).Font.ColorIndex = 2
    Else
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 13 + j).Font.ColorIndex = 1
    End If

    Next j
Next i

'On boucle sur toutes les cellules du tableau de référence 5
For i = 0 To 18
    For j = 0 To 2
    colorertexte = False 'On place un capteur qui se déclenchera au cas ou des valeur sont égales

    For u = 0 To 275
    If rf5(i, j) = rc5(u, 0) Or rf5(i, j) = rc5(u, 1) Or rf5(i, j) = rc5(u, 2) Then colorertexte = True 'Les valeurs sont égales, on declenche le capteur
    Next u

    If colorertexte = True Then 'On vérifie que le capteur se soit déclenché
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 16 + j).Font.ColorIndex = 2
    Else
        ActiveWorkbook.ActiveSheet.Cells(1 + i, 16 + j).Font.ColorIndex = 1
    End If

    Next j
Next i

'On réactive le rafraichissement de l'écran, le calcul automatique et les évenements
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

Merci Beaucoup L-Yann , j'ai tester et ca marche nickel , franchement tu gère 8)

De rien, c'est normal! Le VBA c'est pas toujours facile

N'oublie pas de mettre ton sujet en résolu!

Bonne journée!

Une petite Remarque STP , Quand on fait des copier coller sur la plage de recherche (le tableau de bord) , ca prend un peu du temps , est ce normale ?

Quelle est la taille de la plage de donnée que tu copies-colles? Quelle est la destination de ton copier coller?

C'est le copier-coller qui met du temps ou bien l'exécution de la macro?

par exemple quand je copie juste une cellule , pour coller dans un autre emplacement , la procédure prend du temps , je pense que excel actualise les données