[Besoin de méthode d'optimisation de temps de traitement, macro VBA][RESOLU]

[Thibault LB]

Bonjour à tous,

Je vous explique ma problématique.
Chaque mois un fichier excel est extrait d'une base de données. J'ai besoin de faire une comparaison entre le fichier d'un mois, avec celui du mois précédent. Pour cela, je veux que les cellules qui ont changées soit coloriées en jaune, et si une ligne a été insérée, que toute la ligne soit en jaune, tout ça dans le nouveau fichier.

Ma macro marche très bien. Sauf que les fichiers excel en question font plus de 3700 lignes (pour 37 colonnes), et mon traitement n'arrive jamais au bout (j'ai deja laissé mouliner 1h). J'ai donc fait mes tests finaux sur un fichier redressé a 50 lignes. La fonctionnalité est la, tout marche très bien, avec une résolution immédiate et parfaite, mais le temps de traitement ne me permet pas de l'étendre aux vrais fichiers.

Je me suis dis que peut-être auriez-vous des méthodes pour optimiser un code VBA ?

Voici le code, avec mes explications ci-après :

'Macro permettant de mettre à jour les données France pour chaque onglet, onglet par onglet.
Sub Difference()
'Raccourci clavier : Ctrl + e
'
'Par Thibault Le Bouter

Application.ScreenUpdating = False

'Récupération du fichier actif (depuis lequel on lance la macro) et enregistrement dans l'objet Nouveau.
Dim Nouveau As Workbook
Dim nom As String
nom = ActiveWorkbook.Name
Set Nouveau = Workbooks("" & nom)

'Récupération du fichier avec lequel on veut comparer, par une invite utilisateur. Le fichier est stocké dans l'objet Ancien.
Dim Ancien As Workbook
Dim AN As Variant
AN = Application.GetOpenFilename(FileFilter:="Fichiers Excel (*.xl*), *.xl*", Title:="Choix du fichier de comparaison")
If AN <> False Then
    Set Ancien = Workbooks.Open(AN)
End If

Dim i As Long
Dim Valeur As String
Dim Valeur2 As String
Valeur = ""
Valeur2 = ""

Ancien.Worksheets("global").Activate
Last2 = Cells(65536, 2).End(xlUp).Row 'Récupération de la dernière ligne non vide de l'ancien fichier et stockage dans le variable Last2
For J = 5 To Last2
    'Concaténation de toutes les colonnes, lignes par lignes.
    Cells(J, 38).Value = Cells(J, 2).Value & Cells(J, 3).Value & Cells(J, 4).Value & Cells(J, 5).Value & Cells(J, 6).Value & Cells(J, 7).Value & Cells(J, 8).Value & Cells(J, 9).Value & Cells(J, 10).Value & Cells(J, 11).Value & Cells(J, 12).Value & Cells(J, 13).Value & Cells(J, 14).Value & Cells(J, 15).Value & Cells(J, 16).Value & Cells(J, 17).Value & Cells(J, 18).Value & Cells(J, 19).Value & Cells(J, 20).Value & Cells(J, 21).Value & Cells(J, 22).Value & Cells(J, 23).Value & Cells(J, 24).Value & Cells(J, 25).Value & Cells(J, 26).Value & Cells(J, 27).Value & Cells(J, 28).Value & Cells(J, 29).Value & Cells(J, 30).Value & Cells(J, 31).Value & Cells(J, 32).Value & Cells(J, 33).Value & Cells(J, 34).Value & Cells(J, 35).Value & Cells(J, 36).Value & Cells(J, 37).Value
Next J
Columns("AL").AutoFit

Nouveau.Worksheets("global").Activate
Last = Cells(65536, 2).End(xlUp).Row 'Récupération de la dernière ligne non vide du nouveau fichier et stockage dans le variable Last
For J = 5 To Last
    'Concaténation de toutes les colonnes, lignes par lignes.
    Cells(J, 38).Value = Cells(J, 2).Value & Cells(J, 3).Value & Cells(J, 4).Value & Cells(J, 5).Value & Cells(J, 6).Value & Cells(J, 7).Value & Cells(J, 8).Value & Cells(J, 9).Value & Cells(J, 10).Value & Cells(J, 11).Value & Cells(J, 12).Value & Cells(J, 13).Value & Cells(J, 14).Value & Cells(J, 15).Value & Cells(J, 16).Value & Cells(J, 17).Value & Cells(J, 18).Value & Cells(J, 19).Value & Cells(J, 20).Value & Cells(J, 21).Value & Cells(J, 22).Value & Cells(J, 23).Value & Cells(J, 24).Value & Cells(J, 25).Value & Cells(J, 26).Value & Cells(J, 27).Value & Cells(J, 28).Value & Cells(J, 29).Value & Cells(J, 30).Value & Cells(J, 31).Value & Cells(J, 32).Value & Cells(J, 33).Value & Cells(J, 34).Value & Cells(J, 35).Value & Cells(J, 36).Value & Cells(J, 37).Value
Next J
Columns("AL").AutoFit

If Last > Last2 Then 'Determination de la taille necessaire du tableau
    Dernier = Last
Else
    Dernier = Last2
End If

'Intialisation d'un tableau de la taille du nombres maximum de lignes (Possibilité de 5000 lignes max)
Dim NomTableau(5000) As Integer
For K = 0 To Dernier
    NomTableau(K) = 0
Next K

'Suppression de possible coloriage de cellule précédemment fait (utile par exemple lors d'une erreur de fichier à comparer, ou s'il on veut comparer avec un autre fichier.
For i = 5 To Last
Nouveau.Worksheets("global").Activate
Range("" & i & ":" & i).Interior.ColorIndex = xlAutomatic
Next i

Nouveau.Worksheets("global").Activate


For i = 5 To Last
    Valeur_Test = Nouveau.Worksheets("global").Cells(i, 38).Value 'La valeur qu'on souhaite tester (test sur la valeur précédemment concaténée)
    For numLigne = 5 To Last2 'Boucle for déroulant les cellules concaténées de l'autre fichier.
'On verifie si la valeur Valeur_Test du nouveau fichier est contenue dans l'ancien
        If Ancien.Worksheets("global").Cells(numLigne, 38).Value = Valeur_Test Then
            NomTableau(i) = 0 'Si la valeur est trouvée, on met la ligne du tableau a 0...
            Exit For '...et on arrête la boucle.
        Else
            v = Nouveau.Worksheets("global").Cells(i, 4).Value 'Test sur une colonne a champ unique, pour voir si la ligne existe quand même.
            For numLigne2 = 5 To Last2
                If Ancien.Worksheets("global").Cells(numLigne2, 4).Value = v Then
                    NomTableau(i) = numLigne2   'Si trouvé, on insère le numéro de ligne dans le tableau.
                    Exit For
                Else
                    NomTableau(i) = -1 'Si le code article n'a pas été trouvé, on associe la case a -1 pour traitement plus tard.
                    'Nouveau.Worksheets("global").Range("" & i & ":" & i).Select 'On selectionne les lignes n'étant pas du tout présente dans l'ancien fichier...
                    'Selection.Interior.ColorIndex = 6 '...et on leur associe la couleur jaune.
                End If
            Next numLigne2
        End If
    Next numLigne
Next i




For J = 5 To Dernier 'On déroule le tableau pour récupérer tous les numéros de lignes enregistrés
If NomTableau(J) <> -1 Then
    If NomTableau(J) <> 0 Then 'Si le tableau n'est pas égal à 0 à la case j...
        For c = 2 To 37 '... on parcourt toutes les colonnes pour repérer en quelle(s) cellule(s) il y a différence.
            Valeur = Nouveau.Worksheets("global").Cells(J, c).Value
            'For Each cel In Range("" & NomTableau(J) & ":" & NomTableau(J))
                Valeur2 = Ancien.Worksheets("global").Cells(NomTableau(J), c).Value
                If Valeur <> Valeur2 Then 'Si
                    Nouveau.Worksheets("global").Cells(J, c).Interior.ColorIndex = 6 '...on associe la couleur jaune a la cellule
                End If
                Valeur = "" 'On reinitialise les variables
                Valeur2 = ""
        Next c
    End If
Else 'Si case -1, c'est que la ligne est nouvelle, donc a mettre entierement en jaune.
    Nouveau.Worksheets("global").Range("" & J & ":" & J).Select 'On selectionne les lignes n'étant pas du tout présente dans l'ancien fichier...
    Selection.Interior.ColorIndex = 6 '...et on leur associe la couleur jaune.
End If
Next J




''Même procédure pour le second onglet.
'Ancien.Worksheets("Par code vrac").Activate
'Last3 = Cells(65536, 2).End(xlUp).Row
'For J = 5 To Last2
'    Cells(J, 39).Value = Cells(J, 8).Value & Cells(J, 9).Value & Cells(J, 10).Value & Cells(J, 11).Value & Cells(J, 12).Value & Cells(J, 13).Value & Cells(J, 14).Value & Cells(J, 15).Value & Cells(J, 16).Value & Cells(J, 17).Value & Cells(J, 18).Value & Cells(J, 19).Value & Cells(J, 20).Value & Cells(J, 21).Value & Cells(J, 22).Value & Cells(J, 23).Value & Cells(J, 24).Value & Cells(J, 25).Value & Cells(J, 26).Value & Cells(J, 27).Value & Cells(J, 28).Value & Cells(J, 29).Value & Cells(J, 30).Value & Cells(J, 31).Value & Cells(J, 32).Value & Cells(J, 33).Value & Cells(J, 34).Value & Cells(J, 35).Value & Cells(J, 36).Value & Cells(J, 37).Value & Cells(J, 38).Value
'Next J
'Columns("AM").AutoFit
'
'Nouveau.Worksheets("Par code vrac").Activate
'Last4 = Cells(65536, 2).End(xlUp).Row
'For J = 5 To Last
'    Cells(J, 39).Value = Cells(J, 8).Value & Cells(J, 9).Value & Cells(J, 10).Value & Cells(J, 11).Value & Cells(J, 12).Value & Cells(J, 13).Value & Cells(J, 14).Value & Cells(J, 15).Value & Cells(J, 16).Value & Cells(J, 17).Value & Cells(J, 18).Value & Cells(J, 19).Value & Cells(J, 20).Value & Cells(J, 21).Value & Cells(J, 22).Value & Cells(J, 23).Value & Cells(J, 24).Value & Cells(J, 25).Value & Cells(J, 26).Value & Cells(J, 27).Value & Cells(J, 28).Value & Cells(J, 29).Value & Cells(J, 30).Value & Cells(J, 31).Value & Cells(J, 32).Value & Cells(J, 33).Value & Cells(J, 34).Value & Cells(J, 35).Value & Cells(J, 36).Value & Cells(J, 37).Value & Cells(J, 38).Value
'Next J
'Columns("AM").AutoFit



End Sub

Pour faire court :
1) Je concatène les 37 colonnes de chaque ligne
2) Je fais mes boucles sur chaque ligne, pour vérifier si les champs concaténés sont présents dans l'ancien fichier. Si une cellule a changé dans la ligne, elle apparaitra différent (ATTENTION : les lignes peuvent ne pas être au même endroit d'un mois sur l'autre, il peut y avoir des insertions ou des suppressions, donc je dois bien regarder toutes les lignes pour chaque ligne (sauf s'il elle est trouvé, pas de doublons possible).).
3) Une fois que j'ai récupérer les lignes contenant une difference, je regarde pour chaque cellule, si elle est identique (les colonnes ne bouge pas en revanche, toujours dans le même ordre).

Si vous avez des questions, n'hesitez pas.

Thibault.

 

[Thibault LB]

Re : [Besoin de méthode d'optimisation de temps de traitement, macro VBA]

Bonjour,

Très bonne idée ça ! J'avais pas pensé a cette solution du tout.

Je me lance la dedans . Par contre, quelle est la méthode (/la fonction) pour comparer deux tableaux ? Si tu as ça en stock .
Merci !


EDIT : Bon je me suis renseigné. Est-ce bien avec les Arrays qu'il faut faire ça ? En gros je rentre mes données lignes qui posent problème dans deux tableaux (un pour chaque fichier), et je compare les deux tableaux pour récupérer ensuite les cases qui sont différentes ?

 

[Dranreb]

Re : [Besoin de méthode d'optimisation de temps de traitement, macro VBA]

Comparez les éléments du tableau

For C = 1 to CMAx
   If T1(L1, C) <> T2(L2, C) Then …
   Next C

À +
Peut être auriez vous intéret à faire ça par mise en forme conditionnelle sur formules.
C'est souvent le cas quand il y a des recherches. Les formules peuvent se mettre par macro:

RéfFeui = "[Xl0000414.xls]global!" ' À adapter
Columns(38).FormulaR1C1 = "=MATCH(RC5," & RéfFeui & "C5,0)"
Columns(38).Offset(, 1).Resize(, 37).FormulaR1C1 = _
    "=IF(ISNA(RC38),TRUE,INDEX(" & RéfFeui & "C[-38],RC38)<>RC[-38])"

Ça met des série de VRAI et FAUX en grand nombre derrière, qu'il suffit de d'employer tel quel dans la mefc.

 

[ROGER2327]

Re : [Besoin de méthode d'optimisation de temps de traitement, macro VBA]

Bonsoir à tous

Un essai.
Enregistrez les trois pièces jointes. Décompressez les deux fichiers de données Data_1 et Data_2. Ouvrez le fichier Comparateur. Exécutez Ctrl e pour lancer la procédure de comparaison... ...et voyez si le temps d'exécution est raisonnable. (On travaille sur deux fois 5000 lignes de 36 colonnes.)​

ROGER2327
#6227

Mercredi 25 Tatane 139 (Saint Panurge, moraliste - fête Suprême Quarte)
20 Thermidor An CCXX, 9,9528h - écluse
2012-W32-2T23:53:12Z

 

[ROGER2327]

Re : [Besoin de méthode d'optimisation de temps de traitement, macro VBA]

Suite...

J'étais un peu fatigué cette nuit d'où quelques grossièretés dans le code du module Module1 du fichier Comparateur. Plus correct est :​

Sub tata()
Dim Ancien As Workbook, Nouveau As Workbook, AN1 As Variant, AN2 As Variant
Dim colClef&, i&, j&, k&, l&, m&, msg$, v1(), v2(), r1 As Range, r2 As Range
    ThisWorkbook.Sheets(Feuil0.Name).Copy After:=ThisWorkbook.Sheets(1)
    On Error GoTo E
    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    AN1 = Application.GetOpenFilename(FileFilter:="Fichiers Excel (*.xl*), *.xl*", Title:="Choix du fichier de comparaison")
    AN2 = Application.GetOpenFilename(FileFilter:="Fichiers Excel (*.xl*), *.xl*", Title:="Choix du fichier de comparaison")
    If AN1 <> False And AN2 <> False Then
        Set Ancien = Workbooks.Open(AN1)
        Set Nouveau = Workbooks.Open(AN2)
        colClef = 4 'Colonne de la clef dans les plages de données.
        With Workbooks(Ancien.Name).Sheets("Feuil1").[B3] 'Données anciennes.
            Set r1 = .Parent.Range(.End(xlToRight), .Parent.Cells(.Parent.Rows.Count, .Offset(, colClef - 1).Column).End(xlUp).Offset(, 1 - colClef))
        End With
        ReDim v1(2 To r1.Rows.Count)
        For i = 2 To r1.Rows.Count: v1(i) = r1.Cells(i, colClef).Value: Next 'v1 : répertoire des clefs des données anciennes.
        With Workbooks(Nouveau.Name).Sheets("Feuil1").[B3] 'Données nouvelles.
            Set r2 = .Parent.Range(.End(xlToRight), .Parent.Cells(.Parent.Rows.Count, .Offset(, colClef - 1).Column).End(xlUp).Offset(, 1 - colClef))
        End With
        ReDim v2(2 To r2.Rows.Count)
        For i = 2 To r2.Rows.Count: v2(i) = r2.Cells(i, colClef).Value: Next 'v2 : répertoire des clefs des données nouvelles.
        With ThisWorkbook.ActiveSheet.[C4] 'Données actualisées.
            k = .Row: l = .Column
            .Resize(.Parent.Rows.Count - k, (r1.Columns.Count + r2.Columns.Count + Abs(r1.Columns.Count - r2.Columns.Count)) / 2).Offset(1).Clear
            For i = 2 To UBound(v1)
                For j = 2 To UBound(v2)
                    If v1(i) = v2(j) Then Exit For
                Next
                If j <= UBound(v2) Then 'Ligne de v1 présente dans v2...
                    For m = 1 To r2.Columns.Count
                        If r1.Rows(i).Cells(1, m).Value <> r2.Rows(j).Cells(1, m).Value Then Exit For
                    Next m
                    If m <= r2.Columns.Count Then '...et comportant au moins une différence.
                        k = k + 1
                        r2.Rows(j).Copy Destination:=.Parent.Cells(k, l)
                        .Parent.Cells(k, l).Resize(1, r2.Columns.Count).Interior.ColorIndex = xlColorIndexNone
                        For m = 1 To r2.Columns.Count
                            If r1.Rows(i).Cells(1, m).Value <> r2.Rows(j).Cells(1, m).Value Then .Parent.Cells(k, l + m - 1).Interior.ColorIndex = 6
                        Next m
                    End If
                End If
            Next
        End With
    Else
        With Application: .DisplayAlerts = 0: ThisWorkbook.ActiveSheet.Delete: .DisplayAlerts = 1: End With
    End If
F:
    If Not Nouveau Is Nothing Then Workbooks(Nouveau.Name).Close
    If Not Ancien Is Nothing Then Workbooks(Ancien.Name).Close
    With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
    If msg <> "" Then MsgBox msg, vbOKOnly, "Hélas..."
Exit Sub
'=========================================================================================
E:
    msg = "Une erreur imprévue est survenue."
    Resume F
End Sub

J'ai remplacé la pièce jointe de mon précédent message.​

ROGER2327
#6228

Jeudi 26 Tatane 139 (Saint Glé, neurologue - aliéniste - fête Suprême Quarte)
21 Thermidor An CCXX, 4,1142h - carline
2012-W32-3T09:52:27Z

 

[Thibault LB]

Re : [Besoin de méthode d'optimisation de temps de traitement, macro VBA]

Bonjour Roger !

Merci beaucoup pour le temps passé sur mon problème. J'ai testé tes fichiers ce matin.

Mais finalement, je me suis débrouillé par un autre moyen.
Je suis reparti de mon code de base, en changeant l'ordre de mes tests, avant que le requêtage excel soit le moins fréquent possible. Du coup, ma macro s'est déroulé dans un temps correct (3min par la).
Le seul problème qui persisite, et qui tronque le résultat espéré, est que la personne m'ayant donné ce petit projet ne m'a donné de bonnes informations. La colonne 4, qui était unique selon moi (et selon ses dires) ne l'est en fait pas du tout sur le fichier de 3700 lignes. Donc dans l'état actuel, je ne peux rien faire, n'ayant pas de code unique utilsable pour mes tests de reconnaissances entre les deux fichiers.

Toutefois, je tiens tous à vous remercier pour votre contribution !
Je reste dans les parrages pour aider à résoudre certain problème. Je tiens à apporter ma contribution à ce petit site que je trouve bien sympa.
Merci encore!

A bientôt au détour d'un topic

PS: Topic résolu.

 

[ROGER2327]

Re : [Besoin de méthode d'optimisation de temps de traitement, macro VBA]

Re...

(...) Du coup, ma macro s'est déroulé dans un temps correct (3min par la). (...)

Heureux que votre problème soit résolu, mais trois minutes pour aussi peu de lignes, ça me semble beaucoup...

(...) Le seul problème qui persisite, et qui tronque le résultat espéré, est que la personne m'ayant donné ce petit projet ne m'a donné de bonnes informations. La colonne 4, qui était unique selon moi (et selon ses dires) ne l'est en fait pas du tout sur le fichier de 3700 lignes. (...)

Effectivement, s'il n'y a pas de clef unique, rien ne va plus ! Mais ce n'est pas grave : par définition, le temps des bénévoles n'a pas de prix...​

Bonne continuation.


ROGER2327
#6230

Jeudi 26 Tatane 139 (Saint Glé, neurologue - aliéniste - fête Suprême Quarte)
21 Thermidor An CCXX, 5,7677h - carline
2012-W32-3T13:50:33Z

 

[laetitia90]

Re : [Besoin de méthode d'optimisation de temps de traitement, macro VBA][RESOLU]

bonjour tous
en utilisant un code de JB peut être une piste
vu que la colonne 4 pas unique pas evidant!!
j'ai fais simple pour pas trop bosser copy sur 2 feuilles ton code en a2
le code te donne les lignes differentes de la feuille 2 color jaune ....en blanc identique mais comme dit plus haut en jaune egalement les lignes qui existe pas en feuille 2 ....peut être une base de travail... mais moi pas le temps



ps... pas declarer de variables pas le temps

 

[Thibault LB]

Re : [Besoin de méthode d'optimisation de temps de traitement, macro VBA][RESOLU]

Merci d'avoir regarder un peu ma problématique.

Le coloriage des lignes ayant des champs différents est facilement gérable avec la concaténation des colonnes pour chaque ligne. C'est facilement gérable. Mais pour ce qui est de repérer les cellules exactes, ingérable sans champ unique.

Merci en tout cas.

Je suis sur un autre projet, qui me semble vraiment galère maintenant. Je m'y remet !

Bonne continuation a tous.