Problème de performance avec XL 2016

**dede_bo** · 06/12/2018, 10h24

Bonjour à toutes et tous

J'ai un sérieux souci de performance avec un fichier XL sous Excel 2016 uniquement.

Je possède un fichier ayant 6000 ligne et 35 colonnes. Soit pas grand chose. Certains de ces fichiers peuvent contenir jusque 60.000 lignes.

La macro doit contrôler, pour chaque cellule, si les valeurs sont correctement introduite en fonction de différents paramètres.
Si ce n'est pas le cas, le système doit mettre le fond de la cellule concernée en rouge.
Un popup est affiché et montre les lignes et colonnes en erreur.

Pour toutes les versions d'Excel (2007, 2010 et 2013), le résultat est extrêmement rapide. Comme vous pouvez le voir sur cette vidéo.

Pour info, avec les deux vidéos, je vous montre la vitesse d'exécution pour les 10 premières lignes du document.

Vidéo pour Excel 2010: C'est instantané

Par contre, sous Excel 2016, c'est la catastrophe.
Vidéo pour Excel 2016:

Il n'y a pas photo.

Pour les 6000 lignes, Excel crash. Imaginez pour 60.000 lignes!
Une fois crashé, je dois attendre ± 15min pour que s'ouvre le fichier.

J'ai déjà regardé sur le forum et j'ai mis en pratique les différentes idées de chacun d'entre vous. Sans succès.
Cela me donne l'impression que l'instruction "ScreenUpdating" n'est pas exécuté.

En début de code, j'ai mis les instructions suivante:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
' Augmentation des performances    
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Ce que j'aimerais savoir s'il y a des différences avec Excel 2016 à ce niveau?
Comment puis-je résoudre ce problème?

Comment fonctionne le système:
J'ai écris une fonction où je passe par paramètre : le n° de ligne et l'objet de la feuille.

Je parcours le fichier ligne par ligne.
J’appelle cette fonction qui me retournera la liste des colonnes en erreur.
La fonction change la couleur de la cellule en erreur.

Si quelqu'un parmi vous aurait quelques idées... Cela serait le bienvenu.
Merci d'avance
André

**patricktoulon** · 06/12/2018, 10h32

re
oui c'est pas la premiere fois que l'on vois avec 2016 des lenteurs due a l'acces a la memoire voir a l'acces au object non dispo apres declaration dans VBA

le code serait le bien venu pour voir si on peut améliorer

**dede_bo** · 06/12/2018, 11h12

Bonjour,
J'aimerais vous remercier d'avance pour votre réaction ultra rapide.

Par soucis de confidentialité, j'ai retiré certain ligne de code (protection, valeurs particulières)... Mais cela ne gène en rien au fonctionnement.
Je ne peux pas fournir le fichier lui-même (ordre de mon patron).

Code principal

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
 
Sub CreateDocument()
    DeclareSheet
    Dim rw As Long
    Dim rd As Long
    Dim ct As Long
    Dim cl As Integer
    Dim lstrw As Long
    Dim newfeuille As Worksheet
    Dim zone As String
    Dim texte As String
    Dim message As String
    Dim lgne As Long
    Dim MaxEmpty As Integer
    Dim RwEmpty As Integer
    Dim avancement As Double
    Dim tmp As Long
    Dim pk_check As Boolean
    Dim t As Long
    documentChked = False
 
    ' Calcul le nombre de ligne à traiter
 
    lstrw = 2   ' Ligne des titres
    ct = 1      ' pointeur du tableau d'erreur
 
    ReDim ErrTbl(1)   ' Ce tableau (publique) contiendra la liste des numéros de ligne en erreur (utilisé dans une autre macro)
 
    ' Ne sachant pas où se trouve la donnée la plus basse dans le fichier, je dois parcourir chaque colonne (à l'exception de la primary key).
    ' Et je calcule le n° de ligne le plus bas. Je ne peux pas utiliser l'instruction :  Range(Cel).CurrentRegion.End(xlDown).Row
    ' Car cette primary key descend beaucoup plus bas que les données elles-même.
 
    For cl = 3 To 38
        tmp = LstRows(feuille, ColumnLetter(cl))
        If tmp > lstrw Then
            lstrw = tmp
        End If
    Next cl
 
    ' Ce contrôle est pour voir si le fichier est vide ou non (juste les titres)
    If lstrw = 2 Then
        MsgBox "The template is empty. Nothing to do", vbInformation + vbOKOnly, "Remark"
        fg = True
        Exit Sub
    End If
 
    MaxRw = lstrw   ' Sauve le nombre de ligne. Utilisé lors de la génération du nouveau document (dans une autre macro)
 
    ' Initialise la progress bar
 
    Progress_Status.ProgressBar.Width = 10
    Progress_Status.ProgressBar.Visible = True
 
    Progress_Status.StatusMessage.Clear
 
    Progress_Status.lbl_Progress = "0%  Row: 3 on " & lstrw
    Progress_Status.Bt_Close.Visible = False
    Progress_Status.Repaint
 
    ' Evite le "flashing" durant le traitement
 
    DoEvents
    Progress_Status.Show vbModeless
 
    ' Augmentation des performances
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
 
    message = ""
    avancement = 0  ' calcul de la progress bar
    RwEmpty = 0     ' compteur de ligne vide
    MaxEmpty = 10   ' Je considère la fin du document lorsqu'il y a 10 lignes vide consécutive.
 
    For rw = 3 To lstrw
        ' Contrôle la validité des données de la ligne en cours.
        ckx = checkRow(feuille, rw)
        If Len(ckx) > 0 Then
            ' Ajoute la ligne en erreur dans le popup
            Progress_Status.StatusMessage.AddItem "- There is mistake on row: " & rw & " on following column: " & ckx
 
            ' Ajoute le numéro de la ligne en erreur dans un tableau (utilisé dans une autre macro)
            ErrTbl(ct) = rw
            ct = ct + 1
            ReDim Preserve ErrTbl(ct)
 
            If Len(ckx) = 28 Then
                RwEmpty = RwEmpty + 1
                If RwEmpty > MaxEmpty Then
                    Progress_Status.StatusMessage.AddItem "- End of file"
                    Exit For
                End If
            Else
                RwEmpty = 0
            End If
            total = total + 1
        End If
 
        ' Remet à jour la progress bar
 
        avancement = (rw - 2) / (lstrw - 2) ' retire les titres
 
        Progress_Status.lbl_Progress = "Progress: " & Int(avancement * 10000) / 100 & "%  Row: " & rw & " on " & lstrw
        Progress_Status.ProgressBar.Width = (avancement * 360)   ' Affiche une progress bar
        Progress_Status.Repaint
 
    Next rw
 
    documentChked = True
End Sub

Code de la fonction:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Function checkRow(ws As Worksheet, rw As Long) As String
 
    Dim result As String    ' Recevra la liste des colonnes en erreur (lettre de la colonne)
    Dim zone As String
    Dim cel As Range
    Dim contenu As String
 
    result = ""
    cl = 1
    zone = "A" & rw & ":" & ColumnLetter(LstColumn(ws, 2)) & rw
 
    ws.Range(zone).Interior.ColorIndex = xlNone     ' Avant de contrôler la ligne, j'enlève les éventuelles couleur.
 
    chkval = ws.Cells(rw, 1)                                ' primary key (utilisé lors de l'importation dans une base de donnée). Par confidentialité, je ne peux pas en dire plus.
    p = InStr(1, chkval, "//")
 
 
    zone = "B" & rw & ":" & ColumnLetter(LstColumn(ws, 2)) & rw  ' Zone des données sans la primary key
 
    ' Je compte si toutes les cellules contient une valeur. Si c'est le cas, c'est bon. Je sort de la fonction.
 
    If WorksheetFunction.CountA(ws.Range(zone)) = 0 Then
        ws.Cells(rw, 1).Interior.ColorIndex = xlNone
    Else
       ' Je contrôle la validité de la primary key
        If p > 0 Or Right(chkval, 1) = "/" Then
            ws.Cells(rw, 1).Interior.ColorIndex = 40
        Else
            ws.Cells(rw, 1).Interior.ColorIndex = xlNone
        End If
 
        ' Je parcours chaque cellule
 
        For Each cel In ws.Range(zone)
            contenu = CStr(cel.Value)
 
            ' Je recherche, pour certaines cellules, qu'elles soient remplie avec une valeur particulière. 
            ' 
            If contenu = "" Or IsNull(contenu) Then
                If (cel.Column <> 6 And cel.Column <> 7 And cel.Column <> 8 And cel.Column <> 13 And cel.Column <> 16 And cel.Column <> 18 And cel.Column <> 19 And cel.Column <> 20 And cel.Column <> 21 And cel.Column <> 25 And cel.Column <> 27 And cel.Column <> 28 And cel.Column <> 29 And cel.Column <> 31 And cel.Column <> 32 And cel.Column <> 33 And cel.Column <> 34 And cel.Column <> 35 And cel.Column < 38) Then
                    If cel.Column = 23 Then
                        If Left(cel.Offset(0, -9), 7) = "Pending" Then
                            cel.Value = "N/A"
                        End If
                    ElseIf cel.Column = 36 Then
                        If cel.Offset(0, -21) = "Rejected" Then
                            result = result & " AJ,"
                            cel.Interior.ColorIndex = 40
                        End If
                    ElseIf cel.Column = 37 Then
                        If cel.Offset(0, -8) = "YES" Then
                            result = result & " AK,"
                            cel.Interior.ColorIndex = 40
                        End If
                    Else
                        result = result & ColumnLetter(cel.Column) & ","
                        cel.Interior.ColorIndex = 40
                    End If
                End If
            End If
            cl = cl + 1
        Next cel
 
    End If
 
    If Len(result) > 0 Then
        checkRow = Left(result, Len(result) - 1) ' J'enlève la dernière virgule de la liste
    Else
        checkRow = ""
    End If
End Function

Voilà, si cela peux vous aider.
Encore merci
André

**Patrice740** · 06/12/2018, 11h28

Bonjour,

Il y a une différence apparue avec Excel 2013, la nouvelle interface SDI, qui m'a dèja posé problème avec ScreenUpdating = False, c'est peut-être une piste.
Voir ce fil : https://www.developpez.net/forums/d1.../#post10631486

Édit : Ton screenupdating ne me semble pas placé au bon endroit

**dede_bo** · 06/12/2018, 15h38

Bonjour,
Je viens d'essayer votre idée mais sans succès.

Par contre, ce que j'aimerais faire:
Vu que ce qui prend beaucoup de ressources, c'est de manipuler le graphique.
donc, dans mon esprit, pour chaque erreur trouvée, au lieu de changer la couleur, je remplace par un "flag".
Une fois le contrôle terminé, je remplace la couleur de toutes les cellules ayant ce flag.

Je pense que cela pourrait augmenter les performances.

Mais, comment faire pour sélectionner toutes les cellules "flagées" et remplacer la couleur !

Merci

**Patrice740** · 06/12/2018, 17h19

Envoyé par dede_bo

Bonjour,
Je viens d'essayer votre idée mais sans succès.

Je pense qu'il faut placer le screenupdating avant la création du document.

Vu que ce qui prend beaucoup de ressources, c'est de manipuler le graphique.
donc, dans mon esprit, pour chaque erreur trouvée, au lieu de changer la couleur, je remplace par un "flag".
Une fois le contrôle terminé, je remplace la couleur de toutes les cellules ayant ce flag.

Mais, comment faire pour sélectionner toutes les cellules "flagées" et remplacer la couleur !

Merci

If suffit de "mémoriser" toutes les cellules dans un range (avec Union) puis d'appliquer la couleur au Range

**dede_bo** · 07/12/2018, 13h21

Bonjour,
Sur l'ordinateur ayant Office 2010, la vitesse à augmenté de 50%. Sur Office 2016... Rien à faire, il n'en veut pas!

Voici les modifications que j'ai apporté.

Pour information, j'ai mis : ' ********************************************** entre le code modifié

1° la partie déclarative

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
 
 ' **********************************************
Public FileName As String    ' Pour ne plus utiliser "ActiveWorkbook" mais plustôt Workbooks(FileName)
Public ws As Worksheet      ' J'ai déplacé la déclaration en publique, il n'y a plus qu'une seule déclaration
 ' **********************************************
Public wb As Workbook
Public setup As Worksheet
Public feuille As Worksheet
 
Public fg As Boolean            ' Avoid redundancy
Public fgcode As Boolean      ' Accept data from drop down but not manualy
Public fgSave As Boolean      ' Avoid the saving dialog boxes is showned twice.
 
Public total As Long            ' Number of rows in error
Public MaxRw As Long         ' Number of rows to be treated
Public ErrTbl()                    ' Contains the list of rows in error
Public documentChked As Boolean ' Flag if the control is performed (true) or not (false)

2° sur l’évènement On Open

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
 Private Sub Workbook_Open()
    ' **********************************************
    FileName = ActiveWorkbook.Name  ' Je récupère le nom du fichier
    ' **********************************************
    fg = True
    fgSave = True
End Sub

3° Sur la procédure de contrôle

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
 
Sub CreateDocument()
    ' J'ai tout déplacé au sommet du code.
 
    ' **********************************************
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    ' Evite le "flashing" durant le traitement
    DoEvents
 
    DeclareSheet
    ' **********************************************
    Dim rw As Long
    Dim rd As Long
    Dim ct As Long
    Dim cl As Integer
    Dim lstrw As Long
    Dim newfeuille As Worksheet
    Dim zone As String
    Dim texte As String
    Dim message As String
    Dim lgne As Long
    Dim MaxEmpty As Integer
    Dim RwEmpty As Integer
    Dim avancement As Double
    Dim tmp As Long
    Dim pk_check As Boolean
    Dim t As Long
    documentChked = False
 
    ' Calcul le nombre de ligne à traiter
 
    lstrw = 2   ' Ligne des titres
    ct = 1      ' pointeur du tableau d'erreur
 
    ReDim ErrTbl(1)
 
    For cl = 3 To 38
        tmp = LstRows(feuille, ColumnLetter(cl))
        If tmp > lstrw Then
            lstrw = tmp
        End If
    Next cl
 
    If lstrw = 2 Then
        MsgBox "The template is empty. Nothing to do", vbInformation + vbOKOnly, "Remark"
        fg = True
        Exit Sub
    End If
 
    MaxRw = lstrw   ' Sauve le nombre de ligne. Utilisé lors de la génération du nouveau document
 
    ' Initialise la progress bar
 
    Progress_Status.ProgressBar.Width = 10
    Progress_Status.ProgressBar.Visible = True
 
    Progress_Status.StatusMessage.Clear
 
    Progress_Status.lbl_Progress = "0%  Row: 3 on " & lstrw
    Progress_Status.Bt_Close.Visible = False
    Progress_Status.Repaint
 
    Progress_Status.Show vbModeless
 
    message = ""
    avancement = 0  ' calcul de la progress bar
    RwEmpty = 0     ' compteur de ligne vide
    MaxEmpty = 10   ' Je considère la fin du document lorsqu'il y a 10 lignes vide consécutive.
 
    For rw = 3 To 10
         ' *****************************************************
        ckx = checkRow(rw)  ' J'ai retiré le passage de paramètre de l'objet feuille
         ' *****************************************************
        If Len(ckx) > 0 Then
            Progress_Status.StatusMessage.AddItem "- There is mistake on row: " & rw & " on following column: " & ckx
            ErrTbl(ct) = rw
            ct = ct + 1
            ReDim Preserve ErrTbl(ct)
            If Len(ckx) = 28 Then
                RwEmpty = RwEmpty + 1
                If RwEmpty > MaxEmpty Then
                    Progress_Status.StatusMessage.AddItem "- End of file"
                    Exit For
                End If
            Else
                RwEmpty = 0
            End If
            total = total + 1
        End If
 
        ' Remet à jour la progress bar
 
        avancement = (rw - 2) / (lstrw - 2) ' retire les titres
 
        Progress_Status.lbl_Progress = "Progress: " & Int(avancement * 10000) / 100 & "%  Row: " & rw & " on " & lstrw
        Progress_Status.ProgressBar.Width = (avancement * 360)   ' Affiche une progress bar
        Progress_Status.Repaint
 
    Next rw
 
    documentChked = True
 
    ' **********************************************
    ' Remplace le flag par la couleur de fond
 
    With Application.ReplaceFormat.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .color = 255
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Cells.Replace What:="CTRL_ERR", Replacement:=Empty, LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=True
 
    fg = False
    ' Retire le flag pour ne laisser qu'une cellule vide
    Cells.Replace What:="CTRL_ERR", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
        ReplaceFormat:=False
 
    fg = True
 
    ' Augmentation des performances
 
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    ForEachWinDoEvents    ' Code trouvé sur ce forum
    ' **********************************************
End Sub

4° la fonction qui contrôle une ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
 
Function checkRow(rw As Long) As String
    ' Count how much empty cell and put them in red
    ' ---------------------------------------------
 
    ' **********************************************
    Application.ScreenUpdating = False ' Ajouté cette ligne si jamais l'instruction ne serait privée qu'à la procédure
    DeclareSheet
    ' **********************************************
 
    Dim result As String
    Dim zone As String
    Dim cel As Range
    Dim lstcol As String
    Dim contenu As String
 
    ' **********************************************
    Dim fg_bck As Boolean ' Sauvegarde le flag de modification
    Set ws = feuille
    ' **********************************************
    result = ""
    cl = 1
 
    ' **********************************************
    lstcol = ColumnLetter(LstColumn(ws, 2)) ' Évitez d'appeler la fonction plusieurs fois
    zone = "A" & rw & ":" & lstcol & rw
    ' **********************************************
    'Sauvegarde le flag de modification
    fg_bck = fg
 
    ws.Range(zone).Interior.ColorIndex = xlNone
 
    chkval = ws.Cells(rw, 1)
    p = InStr(1, chkval, "//")
 
 
    zone = "B" & rw & ":" & lstcol & rw
    If WorksheetFunction.CountA(ws.Range(zone)) = 0 Then
        ws.Cells(rw, 1).Interior.ColorIndex = xlNone
    Else
 
        If p > 0 Or Right(chkval, 1) = "/" Then
            ws.Cells(rw, 1).Interior.ColorIndex = 40
        Else
            ws.Cells(rw, 1).Interior.ColorIndex = xlNone
        End If
 
 
        fg = False
 
        For Each cel In ws.Range(zone)
            contenu = CStr(cel.Value)
 
            If contenu = "" Or IsNull(contenu) Then
                If (cel.Column <> 6 And cel.Column <> 7 And cel.Column <> 8 And cel.Column <> 13 And cel.Column <> 16 And cel.Column <> 18 And cel.Column <> 19 And cel.Column <> 20 And cel.Column <> 21 And cel.Column <> 25 And cel.Column <> 27 And cel.Column <> 28 And cel.Column <> 29 And cel.Column <> 31 And cel.Column <> 32 And cel.Column <> 33 And cel.Column <> 34 And cel.Column <> 35 And cel.Column < 38) Then
                    If cel.Column = 23 Then
                        If Left(cel.Offset(0, -9), 7) = "Pending" Then
                            cel.Value = "N/A"
                        End If
                    ElseIf cel.Column = 36 Then
                        If cel.Offset(0, -21) = "Rejected" Then
                            result = result & " AJ,"
                            ' **********************************************
                            cel.Value = "CTRL_ERR"   ' Ajout du flag Erreur
                            'cel.Interior.ColorIndex = 40
                            ' **********************************************
                        End If
                    ElseIf cel.Column = 37 Then
                        If cel.Offset(0, -8) = "YES" Then
                            result = result & " AK,"
                            ' **********************************************
                            cel.Value = "CTRL_ERR"
                            'cel.Interior.ColorIndex = 40
                            ' **********************************************
                        End If
                    Else
                        ws.Unprotect appli & "2016"
                        result = result & ColumnLetter(cel.Column) & ","
                        ' **********************************************
                        cel.Value = "CTRL_ERR"
                        'cel.Interior.ColorIndex = 40
                        ' **********************************************
                    End If
                End If
            End If
            cl = cl + 1
        Next cel
 
    End If
 
    If Len(result) > 0 Then
        checkRow = Left(result, Len(result) - 1)
    Else
        checkRow = ""
    End If
    ' **********************************************
    ' Restore le flag de modification
    fg = fg_bck
   ' **********************************************
End Function

La fonction: DeclareSheet

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
Sub DeclareSheet()
    FileName = ActiveWorkbook.Name
    Set wb = Workbooks(FileName)
    Set feuille = wb.Worksheets("Sheet1")
    Set setup = wb.Worksheets("setup")
End Sub

La fonction: ForEachWinDoEvents

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
Sub ForEachWinDoEvents()
    Dim win As Window
 
    For Each win In Application.Windows
        DoEvents
    Next win
End Sub

Voilà. Je ne sais plus quoi faire !

André

**Patrice740** · 07/12/2018, 14h17

Bonjour,

Impossible de donner une réponse précise sans la totalité du code.

Une seule remarque, au début de la 3° procédure : remplacer DoEvents par ForEachWinDoEvents, car DoEvents n'agit que sur la fenêtre active.

Indépendamment du problème, je suis surpris par tes variables publiques, je conseille de limiter la portée des variables au strict nécessaire (par exemple les déclaration de procédure API). Il n'est jamais nécessaire de déclarer un Classeur ou une feuille en public, il est préférable de les transmettre en variable locale dans les arguments des procédures.

**dede_bo** · 04/01/2019, 11h14

Bonjour,

Bonne année et bonne santé à toutes et tous pour 2019.

Je vous informe que j'ai trouvé la solution. C'est quasi instantané pour 6000 lignes.

Ce que j'ai fait:

1° - J'ai changé la manière de contrôler le document
2° - La gestion des couleurs se font en dehors de la boucle

1° : Le contrôle:

Avant de commencer la boucle de traitement, j'efface les couleurs par:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
zone = "A1:AL6000"
feuille.Range(zone).Interior.ColorIndex = xlNone

Ensuite, dans la boucle de traitement, chaque fois que je trouve une erreur, j'entre le code "CTRL_ERR" dans la cellule concernée.
Je ne manipule pas du tout les couleurs ou le formatage.

2° : La gestion des couleurs:

Une fois la boucle terminée, je remplace simplement la valeur "CTRL_ERR" par vide et je change le formatage.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
Cells.Replace What:= "CTRL_ERR", Replacement:=Empty, LookAt:=xlWhole, _
    SearchOrder:= xlByRows, MatchCase:=True, SearchFormat:=False, _
    ReplaceFormat:=True
Cells.Replace What:= "CTRL_ERR", Replacement:="", LookAt:=xlWhole, _
    SearchOrder:= xlByRows, MatchCase:=True, SearchFormat:=False, _
    ReplaceFormat:=False

Le seule commentaire que j'ai est: je suis obligé de faire ce remplacement en 2 lignes. Excel n'accepte pas en une seule instruction.

Résultat : 6000 lignes contrôlées en moins de 2 secondes.
Voilà
André

Problème de performance avec XL 2016 [XL-2016]

Macros et VBA Excel

Partager

Partager