Macro ralentit à chaque utilisation

**Trust** · 17/09/2008, 14h30

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.

**ouskel'n'or** · 17/09/2008, 14h42

Et si tu nous la mettais, ta macro ?

**Trust** · 17/09/2008, 15h05

Le voici.

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
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

**ouskel'n'or** · 17/09/2008, 16h02

Commence par ajouter "Application.screenUpdating" après ta déclaration

Code :

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

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 :

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

1
2
    Set OpenFile0 = Workbooks(FichierN0)
    DoEvents

... et après chaque fermeture de fichier

Code :

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

1
2
    Workbooks(FichierN0).Close savechanges:=False
    DoEvents

Après, tu dis si c'est toujours aussi lent

A+

**Trust** · 17/09/2008, 16h24

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

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.

Any ideas ?

**neupont** · 17/09/2008, 16h54

Peut-être remplacer "Exit Sub" par "End", vers la fin ?

Macro ralentit à chaque utilisation

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager