Macro ralentit à chaque utilisation

Version imprimable

17/09/2008, 14h30
Trust

Macro ralentit à chaque utilisation

Bonjour à tous !
Je viens de m'apercevoir qu'à chaque lancement de ma macro, celle-ci prend de plus en plus de temps.
Explication :
Je lance ma macro 1 fois => 6 secondes
Je la relance tout de suite après => 10 secondes
Etc... à chaque fois entre 4 et 6 secondes de plus.
Mais, si je ferme mon fichier et que je réouvre, le temps de traitement redevient normal (6 secondes). De plus, si je lance ma macro, que j'enregistre mon fichier et que je relance ma macro alors le temps de traitement reste normal.

Je suppose que certaines variables/objets restent en mémoire même après la fin de la macro et viennent ralentir celle-ci.

Si quelqu'un à une idée.

Merci d'avance

P.S : mon code ou des précisions possible si vous le souhaitez.
17/09/2008, 14h42
ouskel'n'or

Et si tu nous la mettais, ta macro ? ;)

Le voici.

Code:

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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
 
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Private Sub CopieDataAIDEDVP()
 
 '****** Test temps de traitement ******
 Dim Debut As Currency, Fin As Currency, Freq As Currency
 QueryPerformanceCounter Debut
 '**************************************
 
 Dim DerniereLigne As Long 'Dernière Ligne de la BdD après suppression lignes vides
 Dim i As Long 'Compteur boucle
 Dim FichierN0 As String 'Nom du fichier de l'année N-1
 Dim FichierN1 As String 'Nom du fichier de l'année N
 Dim FichierN2 As String 'Nom du fichier de l'année N+1
 Dim Ligne As Long 'Nombre de ligne total de la BdD consolidée
 Dim MsgBxRep As Integer 'Code Réponse MsgBox YesNo
 Dim MsgBxCfg As Integer 'Configuration de la MsgBox
 Dim MsgBxTitre As String 'Titre de la MsgBox
 Dim OpenFile0 As Workbook 'Fichier de la BdD de l'année N-1
 Dim OpenFile1 As Workbook 'Fichier de la BdD de l'année N
 Dim OpenFile2 As Workbook 'Fichier de la BdD de l'année N+1
 Dim Path As String 'Chemin d'accés aux fichiers de BdD
 
 'Initialisation
 On Error GoTo GestionErr
 With Application
    .StatusBar = True
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
 End With
 
 Path = "C:\"
 
 'Indexation des fichiers de BdD
 FichierN1 = Workbooks(ThisWorkbook.Name).Sheets("Feuil1").Range("B8").Value 'NB pour DVP.NET : colle le nom du fichier
 FichierN0 = Workbooks(ThisWorkbook.Name).Sheets("Feuil1").Range("B9").Value 'NB pour DVP.NET : colle le nom du fichier
 FichierN2 = Workbooks(ThisWorkbook.Name).Sheets("Feuil1").Range("B10").Value 'NB pour DVP.NET : colle le nom du fichier
 
 'Demande de mise à jour de la BdD
 MsgBxTitre = "Données"
 MsgBxCfg = vbYesNo + vbQuestion + vbDefaultButton2
 MsgBxRep = MsgBox("Voulez-vous mettre à jour la base de données ?", MsgBxCfg, MsgBxTitre)
 
 If MsgBxRep = vbYes Then
    Application.StatusBar = "Mise à jour Database..."
    ThisWorkbook.Worksheets("Feuil2").Range("A2:J65536").ClearContents
 
    '*** OUVERTURE DES FICHIERS ***
 
    'SI BdD ouvert on passe à la suite SINON on l'ouvre sans mise à jour et en Lecture Seule
    'BdD Année N-1
    On Error Resume Next
    Set OpenFile0 = Workbooks(FichierN0)
    If OpenFile0 Is Nothing Then
        Workbooks.Open Path & FichierN0, UpdateLinks:=0, ReadOnly:=1
        On Error GoTo GestionErr
    End If
 
    'BdD Année N
    On Error Resume Next
    Set OpenFile1 = Workbooks(FichierN1)
    If OpenFile1 Is Nothing Then
        Workbooks.Open Path & FichierN1, UpdateLinks:=0, ReadOnly:=1
        On Error GoTo GestionErr
    End If
 
    'BdD Année N+1
    On Error Resume Next
    Set OpenFile2 = Workbooks(FichierN2)
    If OpenFile2 Is Nothing Then
        Workbooks.Open Path & FichierN2, UpdateLinks:=0, ReadOnly:=1
        On Error GoTo GestionErr
    End If
 
    '*** COPIE DES DONNÉES ***
 
    'Données Année N-1
    With Workbooks(ThisWorkbook.Name).Sheets("Feuil2")
        Ligne = .Range("A2").SpecialCells(xlCellTypeLastCell).Row + 1
        Workbooks(FichierN0).Sheets("sheets").Range("TB_data").Copy
        Workbooks(ThisWorkbook.Name).Sheets("Feuil2").Range("A" & Ligne).PasteSpecial (xlPasteValues)
    End With
 
    'Données Année N
    With Workbooks(ThisWorkbook.Name).Sheets("Feuil2")
        Ligne = .Range("A2").SpecialCells(xlCellTypeLastCell).Row + 1
        Workbooks(FichierN1).Sheets("sheets").Range("TB_data").Copy
        Workbooks(ThisWorkbook.Name).Sheets("Feuil2").Range("A" & Ligne).PasteSpecial (xlPasteValues)
    End With
 
    'Données Année N+1
    With Workbooks(ThisWorkbook.Name).Sheets("Feuil2")
        Ligne = .Range("A2").SpecialCells(xlCellTypeLastCell).Row + 1
        Workbooks(FichierN2).Sheets("sheets").Range("TB_data").Copy
        Workbooks(ThisWorkbook.Name).Sheets("Feuil2").Range("A" & Ligne).PasteSpecial (xlPasteValues)
    End With
 
    ' *** FERMETURE DES FICHIERS ***
 
    Application.CutCopyMode = False
    Workbooks(FichierN0).Close savechanges:=False
    Workbooks(FichierN1).Close savechanges:=False
    Workbooks(FichierN2).Close savechanges:=False
 
 
    ' *** CONSOLIDATION DES DONNÉES ***
 
    'Tri des données par numéro de salarié
    ThisWorkbook.Sheets("Feuil2").Range("A6:J65536").Sort _
        Key1:=Range("A2"), Order1:=xlAscending
 
    'Suppression lignes vides
    With ThisWorkbook.Sheets("Feuil2")
        For i = Ligne To 1 Step -1
            If .Cells(i, 1).Value = "" Then
                Rows(i).Delete
            End If
        Next i
    End With
 
    'Extension des formules pour calcul des dates MAX/MIN
    DerniereLigne = Sheets("Feuil2").Cells(Ligne, 1).End(xlUp).Row
    With ThisWorkbook
        .Sheets("Feuil2").Range("K2:P2").Copy
        .Sheets("Feuil2").Range("K2:P" & DerniereLigne).PasteSpecial Paste:=xlPasteFormulas
        .Sheets("Feuil2").Range("K2:P" & DerniereLigne).PasteSpecial Paste:=xlPasteFormats
        .Sheets("Feuil1").Activate
    End With
 
    Application.CutCopyMode = False
 
 'Si on refuse la mise à jour des données
 Else
     MsgBxRep = MsgBox("Les données risquent d'être invalides !", vbCritical, "ERROR")
 
 End If
 
 With Application
    .ScreenUpdating = True
    .StatusBar = False
    .Calculation = xlCalculationAutomatic
 End With
 
 '****** Test temps de traitement ******
 QueryPerformanceCounter Fin
 QueryPerformanceFrequency Freq
 MsgBox "Tps de traitement = " & Format(((Fin - Debut) / Freq), "0.000") & " sec."
 '**************************************
 
 Exit Sub
 
' *** GESTIONNAIRE D'ERREURS ***
 
GestionErr:
'indique le numéro et la description de l'erreur
 MsgBox "Erreur type " & Err.Number & vbLf & Err.Description & vbLf, vbCritical
 With Application
    .Calculation = xlCalculationAutomatic
    .CutCopyMode = False
    .ScreenUpdating = True
    .StatusBar = "Erreur Macro"
 End With
 
End Sub

Merci encore.
Et merci de votre indulgence, je ne suis pas expert en VBA :aie:

17/09/2008, 16h02
ouskel'n'or
Commence par ajouter "Application.screenUpdating" après ta déclaration
Code:

1 2 Dim Path As String 'Chemin d'accés aux fichiers de BdD Application.screenUpdating = False
que tu repasses à true en fin de sub
Ensuite, ajoute DoEvents après chaque ouverture
Code:

1 2 Set OpenFile0 = Workbooks(FichierN0) DoEvents
... et après chaque fermeture de fichier
Code:

1 2 Workbooks(FichierN0).Close savechanges:=False DoEvents
Après, tu dis si c'est toujours aussi lent ;)
A+
17/09/2008, 16h24
Trust

Merci ouskel'n'or.
Je gagne plus d'une seconde sur ma macro ce qui est pas mal.
Ce matin j'ai commencé à 10 secondes au mieux.
J'en suis à 4.5 sec :king:

Mais (parce qu'il y a toujours un "mais") le problème de ralentissement au fur et à mesure de l'utilisation de la macro persiste.
Je commence à 4.5 sec et si je la relance le temps de traitement est de 6.3 ... C'est plus rapide et ça augmente moins vite (entre 2 et 3 sec alors qu'avant ça augmentait entre 4 et 6 sec) mais le problème reste entier. 8O

Any ideas ?
17/09/2008, 16h54
neupont

Peut-être remplacer "Exit Sub" par "End", vers la fin ?
17/09/2008, 17h07
Trust

J'utilise Exit Sub pour mettre mon gestionnaire d'erreurs à la fin. Je ne pense pas que ça soit ça étant donné qu'il quitte bien la sub.
17/09/2008, 17h21
helios77

Moi je te conseillerais un truc.....

Calculer le temps mis entre chaque partie de ton code pour voir quelle partie devient de plus en plus gourmande avec le nombre d'éxécution

Comment ?
Au départ de ton code, tu fais un Date D1 = now()
Après une partie de ton code, tu affiches une datediff entre Now et D1 (avec une msgbox)

ensuite, tu réinitialises D1 avec now et tu refais le date diff après un autre bloc

tu notes tous les temps de traitement à chaque fois et tu verras si l'augmentation se fait au fur et à mesure partout ou si elle se fait uniquement sur un bloc bien précis

par dichotomie, tu devrais tomber sur la ligne en cause de ces ralentissements assez rapidement et après nous pourrons voir comment optimiser la ligne en question.....

Personnellement, c'est ce que je ferais dans un premier temps....
17/09/2008, 18h43
ucfoutu

Bonsoir,

essaye de libérer un peu la mémoire, également.

Tu établis par set 3 objets, du genre (ici un exemple) :

Code:

Set OpenFile0 = Workbooks(FichierN0)

utilise dinc :

Code:

Set OpenFile0 = Nothing

dès que tu n'as plus besoin de cet objet.
17/09/2008, 19h06
alsimbad

suggestion peut etre fantaisiste ?
cette macro utilise beaucoup le copiercoller. il me semble qu'il y avait eu un post avec qqun qui avait ce soucis, et il y avait eu une discussion assez longue, je crois sur cette option pour un probleme , me semble t'il similaire. toute l'histoire consistant je crois a vider le presse papier. mais je ne suis sur de rien, si ça peut aider :roll:
18/09/2008, 09h46
neupont

Citation:

Envoyé par Trust

J'utilise Exit Sub pour mettre mon gestionnaire d'erreurs à la fin. Je ne pense pas que ça soit ça étant donné qu'il quitte bien la sub.

"End" (je ne parle pas de "End Sub") ferait la même chose en réinitialisant les variables. Enfin je ne sais pas, c'est toi même qui a émis l'hypothèse que "certaines variables/objets restent en mémoire même après la fin de la macro et viennent ralentir celle-ci", ce qui est bien possible en effet.
C'est pas lourd à tester, et tu dois aussi pouvoir gagner du temps en essayant les autres suggestions.
18/09/2008, 09h59
ouskel'n'or
Pour supprimer les lignes vides, tu peux utiliser cette syntaxe
Code:

1 2 3 With ThisWorkbook.Sheets("Feuil1").UsedRange .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp End With
Je pense que le parcours d'une plage de cellule pour connaître les cellules vides est une bonne raison de ralentir un code.

Après, tu dis mais là je pense que tu vas gagner du temps ;)
A+

Edit
As-tu déclaré toutes tes variables ?

Citation:

Envoyé par neupont

"End" (je ne parle pas de "End Sub") ferait la même chose en réinitialisant les variables. Enfin je ne sais pas, c'est toi même qui a émis l'hypothèse que "certaines variables/objets restent en mémoire même après la fin de la macro et viennent ralentir celle-ci", ce qui est bien possible en effet.
C'est pas lourd à tester, et tu dois aussi pouvoir gagner du temps en essayant les autres suggestions.

j'ai testé et le problème reste le même, même si mes variables sont effectivement réinitiliasées.

Citation:

Envoyé par ucfoutu

Bonsoir,

essaye de libérer un peu la mémoire, également.

Tu établis par set 3 objets, du genre (ici un exemple) :

Code:

Set OpenFile0 = Workbooks(FichierN0)

utilise dinc :

Code:

Set OpenFile0 = Nothing

dès que tu n'as plus besoin de cet objet.

Déjà fait après avoir cherché sur le forum, je gagne quelques 1/10ème de secondes ;)

Citation:

Envoyé par alsimbad

suggestion peut etre fantaisiste ?
cette macro utilise beaucoup le copiercoller. il me semble qu'il y avait eu un post avec qqun qui avait ce soucis, et il y avait eu une discussion assez longue, je crois sur cette option pour un probleme , me semble t'il similaire. toute l'histoire consistant je crois a vider le presse papier. mais je ne suis sur de rien, si ça peut aider :roll:

J'ai regardé sur le forum et les posts sur ça sont intéressants dans la mesure où les grand copier-coller dans la même macro ralentissent celle-ci.
La fonction EmpytClipBoard permet de vider le presse papier et de gagner du temps.
Je laisse le code pour ceux que ça intéressent :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Option Explicit Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function CloseClipboard Lib "user32" () As Long Sub VideClipBoard() OpenClipboard 0 EmptyClipboard CloseClipboard End Sub
Dans les références de l'éditeur VBA, il faut que Microsoft Forms 2.0 Object Library soit coché.

Mais ma macro continue de ralentir au fur et à mesure de son utilisation...:aie:

18/09/2008, 15h01
ouskel'n'or

As-tu testé la suppression des lignes vides que j'ai mise + haut ? :evilred:
18/09/2008, 15h03
Trust
Citation:
Envoyé par ouskel'n'or

Pour supprimer les lignes vides, tu peux utiliser cette syntaxe

Code:

1 2 3 With ThisWorkbook.Sheets("Feuil1").UsedRange .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp End With

Je pense que le parcours d'une plage de cellule pour connaître les cellules vides est une bonne raison de ralentir un code.

Après, tu dis mais là je pense que tu vas gagner du temps ;)
A+

Edit
As-tu déclaré toutes tes variables ?
Oui toutes les variables sont déclarées (l'option Explicit ça aide pour prendre de bonnes habitudes :yaisse2:).

Ton code accélère ma macro en divisant le temps par 2 !
Et de plus, le problème de ralentissement si on utilisait la macro plusieurs fois à la suite est résolu aussi ! :king:

Apparemment il s'agissait de la boucle de suppression des lignes vides qui posait problème.

Pour info la macro s'exécute en moins de 2 secondes alors qu'elle prenait 10 secondes au mieux hier matin.

Merci à tous ! Ce fut très instructif.
Et chapeau bas à toutes vos idées :king:

EDIT : désolé j'ai été un peu long à écrire le post ouskel'n'or ! :oops: