"Lighter" un code qui colore des cellules

P

Pineurne

XLDnaute Junior
Bonjour à tous,

Voilà je suis assez ennuyé. J'ai créé une macro dont la fonction est la suivante : j'ai 2 onglets "Fichier1" et "Fichier2". Je veux comparer ces 2 onglets et faire ressortir lorsqu'il y a une différence. Pour ce faire, j'analyse ligne par ligne et s'il n'y a pas de différences, alors je coloris la case A des 2 onglets. Voici le code que j'ai utilisé :

Code: 
While Sheets("Fichier1").Range("A" & i1).Value <> 0
        doc_fichier1_cree = True
        While Sheets("Fichier2").Range("A" & i2).Value <> 0
            If Sheets("Fichier1").Range("A" & i1).Value = Sheets("Fichier2").Range("A" & i2).Value And Sheets("Fichier1").Range("K" & i1).Value = Sheets("Fichier2").Range("K" & i2).Value And Sheets("Fichier1").Range("R" & i1).Value = Sheets("Fichier2").Range("R" & i2).Value And Sheets("Fichier1").Range("S" & i1).Value = Sheets("Fichier2").Range("S" & i2).Value And Sheets("Fichier1").Range("T" & i1).Value = Sheets("Fichier2").Range("T" & i2).Value Then
                doc_fichier1_cree = False
                Sheets("Fichier2").Select
                Range("A" & i2).Select
                With Selection.Interior
                    .ColorIndex = 6
                    .Pattern = xlSolid
                End With
            End If
            i2 = i2 + 1
        Wend
        If doc_fichier1_cree = False Then
            Sheets("Fichier1").Select
            Range("A" & i1).Select
            With Selection.Interior
                    .ColorIndex = 6
                    .Pattern = xlSolid
            End With
        End If
        i2 = 2
        i1 = i1 + 1
    Wend

Mon problème est que j'ai 5000 lignes dans mes 2 onglets et le temps de traitement s'avère donc extrêmement long ! Je précise que je ne suis pas un expert en programmation, mais j'aime bien bidouiller et me faire des petits outils. Avez-vous une idée de comment alléger le code ?

Merci d'avance !
 
Trier par date Trier par votes
F

flyonets44

XLDnaute Occasionnel
Re : "Lighter" un code qui colore des cellules

Bonsoir
tu mets ces lignes en début de macro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
et celle-ci avant le end sub
Application.Calculation = xlCalculationAutomatic
Cordialement
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : "Lighter" un code qui colore des cellules

(re)Bonjour Pineurne,

Tu trouveras ci-joint un fichier avec trois méthodes différentes.
1) on utilise la commande Find
2) on utilise les filtres automatiques
3) on utilise une formule basée sur Sommeprod

Les temps d'exécutions diffèrent selon que les données sont triées (tri sur colonnes A,K,R,S,T) ou non triées (5000 lignes):
1) triées:225s non triées:235s
2) triées:109s non triées:411s
3) triées: 48s non triées: 48s

On doit sans doute pouvoir encore faire moins!
Le fichier:Regarde la pièce jointe Compar V3.zip
 
Dernière édition:
Vote positif 0 Vote négatif
P

Pineurne

XLDnaute Junior
Re : "Lighter" un code qui colore des cellules

Bonjour,

Merci pour votre aide.
flyonets44, j'ai testé de rajouter ce que tu m'as dit dans mon code mais ça ne réduit pas vraiment le temps de calcul. Je trouve que c'est toujours aussi long.
mapomme, je t'avoue que je ne comprends pas très bien ce que tu as fait. Ton code est complètement différent de celui que j'ai fait donc j'ai un peu de mal à l'analyser. Peux-tu m'en dire + ?

Merci d'avance pour votre patience :)
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : "Lighter" un code qui colore des cellules

Bonjour Pineurne, mapomme, flyonets44,
Pour gagner du temps on peux commencer par supprimer ces vilains Selects :D:
VB: 
Sub Test()
Dim doc_fichier1_cree As Boolean, F1 As Worksheet, F2 As Worksheet, I1&, I2&
I1 = 1: I2 = 1
Set F1 = Sheets("Fichier1")
Set F2 = Sheets("Fichier2")
While F1.Range("A" & I1).Value <> 0
    doc_fichier1_cree = True
    While F2.Range("A" & I2).Value <> 0
        If F1.Range("A" & I1).Value = F2.Range("A" & I2).Value And _
            F1.Range("K" & I1).Value = F2.Range("K" & I2).Value And _
            F1.Range("R" & I1).Value = F2.Range("R" & I2).Value And _
            F1.Range("S" & I1).Value = F2.Range("S" & I2).Value And _
            F1.Range("T" & I1).Value = F2.Range("T" & I2).Value Then
            doc_fichier1_cree = False
            With F2.Range("A" & I2).Interior
                .ColorIndex = 6
                .Pattern = xlSolid
            End With
        End If
        I2 = I2 + 1
    Wend
    If doc_fichier1_cree = False Then
        With F1.Range("A" & I1).Interior
            .ColorIndex = 6
            .Pattern = xlSolid
        End With
    End If
    I2 = 2
    I1 = I1 + 1
Wend
End Sub

Ensuite on peux surement aller beaucoup plus vite mais pour ça il faudrait un exemple, annonyme, avec quelques lignes significatives (15 ou 20 sur chaque feuille), pour voir la structure des feuilles (y a t il des cellules fusionnées, des formules qui risquent d'être en erreur, etc...) ainsi que le code en entier....
A te re lire avec l'exemple.
Cordialement
 
Dernière édition:
Vote positif 0 Vote négatif
P

Pineurne

XLDnaute Junior
Re : "Lighter" un code qui colore des cellules

J'ai mis un fichier ci-joint pour exemple.
J'ai lighté le fichier, allé jusqu'à la ligne 20. C'est étrange car avec ce fichier, le traitement est très rapide (beaucoup + qu'avec mes onglets originaux... :confused:

En gros :
En jaune lorsque c'est inchangé
En rose lorsque U, V ou W sont modifiés
En blanc lorsque la ligne est créée ou supprimée par rapport à l'autre onglet

Je ne comprends pas pourquoi sur un exemple le traitement devient rapide... :confused:
 

Pièces jointes

  • Fich_Exemple.xls
    75 KB · Affichages: 52
  • Fich_Exemple.xls
    75 KB · Affichages: 52
  • Fich_Exemple.xls
    75 KB · Affichages: 62
Vote positif 0 Vote négatif
F

flyonets44

XLDnaute Occasionnel
Re : "Lighter" un code qui colore des cellules

Bonjour
j'ai juste rajouté les lignes de code que je t'avais proposées; le traitement
est instantané chez moi
Cordialement
Flyonets
 

Pièces jointes

  • Fich_Exemple.xls
    67 KB · Affichages: 49
  • Fich_Exemple.xls
    67 KB · Affichages: 50
  • Fich_Exemple.xls
    67 KB · Affichages: 49
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : "Lighter" un code qui colore des cellules

Re
Il est évident que sur deux tableaux de 20 lignes, tous les codes vont assez vite (heureusement... :rolleyes:).
Sur l'exemple il s'agit de vérifier 400 passages de boucles 20 X 20. Sur le vrai fichier on parle de 5 000 lignes, soit 2 500 000 passages de boucles, et là ce n'est pas une mince affaire.
Avec les colorations de cellules le temps de traitement est "colossal".
Je regarderai plus avant demain, mais pour l'instant je n'ai pas fait vraiment mieux que mapomme(version SOMMEPROD).
J'en suis là:
VB: 
Sub Test_2()
Dim F1 As Worksheet, F2 As Worksheet, I1&, I2&
Application.ScreenUpdating = False
Set F1 = Sheets("Fichier1")
Set F2 = Sheets("Fichier2")
For I1 = 2 To F1.Cells(Rows.Count, 1).End(xlUp).Row
    For I2 = 2 To F2.Cells(Rows.Count, 1).End(xlUp).Row
        If F1.Range("A" & I1).Value = F2.Range("A" & I2).Value And _
            F1.Range("K" & I1).Value = F2.Range("K" & I2).Value And _
            F1.Range("R" & I1).Value = F2.Range("R" & I2).Value And _
            F1.Range("S" & I1).Value = F2.Range("S" & I2).Value And _
            F1.Range("T" & I1).Value = F2.Range("T" & I2).Value Then
                F1.Range("A" & I1).Interior.ColorIndex = 6
                F2.Range("A" & I2).Interior.ColorIndex = 6
        End If
    Next I2
Next I1
Application.ScreenUpdating = False
End Sub
Voir ici:
VB: 
Sub Test_Tab()
Dim F1 As Worksheet, F2 As Worksheet, I1&, I2&, TabF1(), TabF2(), Deb!
Deb = Timer
Application.ScreenUpdating = False
Set F1 = Sheets("Fichier1"): Set F2 = Sheets("Fichier2")
TabF1 = F1.UsedRange.Value
TabF2 = F2.UsedRange.Value
F1.Columns(1).Interior.ColorIndex = xlNone
F2.Columns(1).Interior.ColorIndex = xlNone
For I1 = LBound(TabF1, 1) + 1 To UBound(TabF1, 1)
    For I2 = LBound(TabF2, 1) + 1 To UBound(TabF2, 1)
        If TabF1(I1, 1) = TabF2(I2, 1) And _
            TabF1(I1, 11) = TabF2(I2, 11) And _
            TabF1(I1, 18) = TabF2(I2, 18) And _
            TabF1(I1, 19) = TabF2(I2, 19) And _
            TabF1(I1, 20) = TabF2(I2, 20) Then
                F1.Cells(I1, 1).Interior.ColorIndex = 6
                F2.Cells(I2, 1).Interior.ColorIndex = 6
                Exit For
        End If
    Next I2
Next I1
Application.ScreenUpdating = True
MsgBox Timer - Deb
End Sub

Si quelqu'un a une idée...
Cordialement
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : "Lighter" un code qui colore des cellules

Re
Et pour essayer de toucher le moin possible à la feuille, on peux même tenter ça:
VB: 
Sub Test_Tab_2()
Dim F1 As Worksheet, F2 As Worksheet, I1&, I2&, TabF1(), TabF2(), Deb!, Liste$
Deb = Timer
Application.ScreenUpdating = False
Set F1 = Sheets("Fichier1"): Set F2 = Sheets("Fichier2")
TabF1 = F1.UsedRange.Value
TabF2 = F2.UsedRange.Value
F1.Columns(1).Interior.ColorIndex = xlNone
F2.Columns(1).Interior.ColorIndex = xlNone
Liste = ","
For I1 = LBound(TabF1, 1) To UBound(TabF1, 1)
    For I2 = LBound(TabF2, 1) To UBound(TabF2, 1)
            If TabF1(I1, 1) = TabF2(I2, 1) And _
                TabF1(I1, 11) = TabF2(I2, 11) And _
                TabF1(I1, 18) = TabF2(I2, 18) And _
                TabF1(I1, 19) = TabF2(I2, 19) And _
                TabF1(I1, 20) = TabF2(I2, 20) Then
                    F1.Cells(I1, 1).Interior.ColorIndex = 6
                    If InStr(Liste, "," & I2 & ",") = 0 Then
                        F2.Cells(I2, 1).Interior.ColorIndex = 6
                        Liste = Liste & I2 & ","
                    End If
                    Exit For
            End If
    Next I2
Next I1
Application.ScreenUpdating = True
MsgBox Timer - Deb
End Sub
Cordialement
 
Vote positif 0 Vote négatif
P

Pineurne

XLDnaute Junior
Re : "Lighter" un code qui colore des cellules

Oui c'est que j'allais dire : j'ai retesté sur un fichier simple mais avec 5000 lignes et le temps de traitement est trèèèès long. Même avec ce que tu disais flyonets.

Je comprends ton code Efgé, je vais tester et je vous tiens au jus. Un autre problème est que je ne comprends pas le code version Find ou Sommeprod...

En tout cas, merci !
 
Dernière édition:
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : "Lighter" un code qui colore des cellules

Re
Je pense que ceci devrait aller plus vite, on ne touche plus à la feuille...
VB: 
Sub Test_Tab_3()
Dim F1 As Worksheet, F2 As Worksheet, I1&, I2&, TabF1(), TabF2(), Deb!, Liste$, ListeF1$, ListeF2$
Deb = Timer
Application.ScreenUpdating = False
Set F1 = Sheets("Fichier1"): Set F2 = Sheets("Fichier2")
TabF1 = F1.UsedRange.Value
TabF2 = F2.UsedRange.Value
F1.Columns(1).Interior.ColorIndex = xlNone
F2.Columns(1).Interior.ColorIndex = xlNone
Liste = ","
For I1 = LBound(TabF1, 1) + 1 To UBound(TabF1, 1)
    For I2 = LBound(TabF2, 1) + 1 To UBound(TabF2, 1)
            If TabF1(I1, 1) = TabF2(I2, 1) And _
                TabF1(I1, 11) = TabF2(I2, 11) And _
                TabF1(I1, 18) = TabF2(I2, 18) And _
                TabF1(I1, 19) = TabF2(I2, 19) And _
                TabF1(I1, 20) = TabF2(I2, 20) Then
                    ListeF1 = ListeF1 & F1.Cells(I1, 1).Address & ","
                    If InStr(Liste, "," & I2 & ",") = 0 Then
                        ListeF2 = ListeF2 & F2.Cells(I2, 1).Address & ","
                        Liste = Liste & I2 & ","
                        Exit For
                    End If
            End If
    Next I2
Next I1
ListeF1 = Left(ListeF1, Len(ListeF1) - 1)
ListeF2 = Left(ListeF2, Len(ListeF2) - 1)
F1.Range(ListeF1).Interior.ColorIndex = 6
F2.Range(ListeF2).Interior.ColorIndex = 6
Application.ScreenUpdating = True
MsgBox Timer - Deb
End Sub

Cordialement
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Re : "Lighter" un code qui colore des cellules

re(Bonsoir) le forum & Efgé,

Je coince sur : F1.Range(ListeF1).Interior.ColorIndex = 6
J'ai l'impression que dès que la longueur de ListeF1 dépasse 255 caractères, Range(ListeF1) échoue.

Code: 
Sub RangeString()
Dim S, i, T

S = "A99"
On Error GoTo RangeString_err01
For i = 2 To 1000
    T = S
    S = S & ",A" & i
    Range(S).Select
Next i
Exit Sub

RangeString_err01:
MsgBox "S ok  -  len(S)= " & Len(T) & vbCrLf & T & vbCrLf & vbCrLf & _
        "S ko  -  len(S)= " & Len(S) & vbCrLf & S
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
1 K
thivame
T
D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
445
Dranreb
Dranreb
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
278
Compte Supprimé 979
C
Usine à gaz
  • Question
XL 2021 Accélérer la copie du classeur actif faite par vba
2 3 4
Réponses
45
Affichages
2 K
Usine à gaz
Usine à gaz
R
  • Question
XL 2021 Optimisation Code VBA
Réponses
10
Affichages
418
Dranreb
Dranreb
G
  • Résolu(e)
Copie de données d'une feuille à une autre
Réponses
2
Affichages
245
gui22
G
F
  • Question
XL 2019 erreur 1004
Réponses
8
Affichages
268
florian50470
F
Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
301
Zonmé
Z
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
106
Latias
L
M
  • Résolu(e)
XL 2016 Amélioration de code
Réponses
3
Affichages
391
M@xu3L
M

Membres actuellement en ligne

9 membres et 83 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 492
Messages
2 088 938
Membres
103 988
dernier inscrit
Feonix