Excel se bloque si une macro est utilisée plusieurs fois

**philou32** · 24/08/2018, 03h32

Bonjour,

dans une feuille excel, j'ai une macro en VBA qui crée un ou plusieurs graphiques en fonction de conditions dans différentes feuilles.

Pour identifier la source du problème, j'ai mis des conditions pour que la macro ne génére que 2 graphiques.
Si la macro est exécuté qu'une seule fois, elle s'exécute correctement. Si je relance la macro, excel se plante...., l'écran est gelé ou n'est plus mis à jour.

les graphiques ne sont pas très gros: par graphique: 6 courbes de 53 points

dans le Task manager, je constate que la mémoire utilisée augmente à chaque exécution de la macro et n'est jamais libérée.

**philou32** · 24/08/2018, 08h25

pour info complémentaire:
sur Office 2010, la macro tourne sans aucun problème ...

les 2 PCs sont neuf et exécutent windows 10 avec 16 GB ram

**halaster08** · 24/08/2018, 10h10

Bonjour,

Plutôt que de cacher ta macro dans un fichier texte à télécharger (ce que beaucoup d'intervenant ne feront pas), pourquoi ne pas la poster directement dans ton message (en utilisant les balises codes prévues pour ça)

**philou32** · 24/08/2018, 11h09

Bonjour
voici la macro mais je pense que le prolème vient plus de la configuration de office 2016 ou windows.
j'ai fait le test sur un autre PC avec windows 10 et office 2016 et là, je n'ai aucun problème de fonctionnement ou de mémoire.
Dans le cas présent, la mémoire utilisée augment à chaque relance de la macro.

voici la macro:

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
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
Sub graph_IK()
 
'===========================================================
'crée les graphiques d'évolution dans chaque rapport sales
'
'Crée une table temporaire des données pour les graphiques
'input:parameter - annéé en cours - année n-1
'
'output:rp_xxxx (sales)
'===========================================================
    Set DicoIKArea = CreateObject("Scripting.Dictionary")
    DicoIKArea.CompareMode = vbTextCompare
 
    Application.ScreenUpdating = False
 
    b = Sheets("parameter").Range("A6:B" & Sheets("parameter").[B16].End(xlUp).Row) ' tableau a(n,1) pour rapidité
    For i = LBound(b) To UBound(b)
      If b(i, 1) <> "" Then
        DicoIKArea(b(i, 1)) = Array(b(i, 2), 0, 0)
        End If
    Next i
    ttemp = Worksheets("parameter").Range("A80").End(xlToRight).Column - 2
    nbrprod = Worksheets("parameter").Range("A80").End(xlDown).Row
    For i = 1 To ttemp
        kk = Sheets("parameter").Cells(80, i + 1)
        temp = DicoIKArea(kk)
        temp(1) = Sheets("parameter").Cells(nbrprod, i + 1)
        temp(2) = Sheets("parameter").Cells(nbrprod - 1, i + 1)
        DicoIKArea(kk) = temp
    Next i
 
 
    Set DicoAct2 = CreateObject("Scripting.Dictionary")  ' dict IK - area - groupe - année - week : C.A. de la semaine par famille
    DicoAct2.CompareMode = vbTextCompare
    Set DicoNCA = CreateObject("Scripting.Dictionary")
    DicoNCA.CompareMode = vbTextCompare
    Set DicoCA = CreateObject("Scripting.Dictionary")
    DicoCA.CompareMode = vbTextCompare
 
 
 
'créer un tableau pivot pour chaque année => pv-...
 
    active_year = StrConv(Sheets("parameter").Range("B2"), 2)
    prev_year = active_year - 1
    firstyear = StrConv(Sheets("parameter").Range("B3"), 2)
    nbryear = active_year - firstyear + 1
'===========================================================
'Crée les dictionnaires pour le CA - marge et NCA
'===========================================================
 
 
    For i = Sheets("parameter").Range("B3") To Sheets("parameter").Range("B2")
        currentyear = StrConv(i, 2)
        Set a = Nothing
        ttt = Sheets(currentyear).[a1].End(xlDown).Row
        a = Sheets(currentyear).Range("a1:z" & ttt)   ' tableau a(n,1)
        b = 0
 
        For j = LBound(a) + 1 To UBound(a)
            If a(j, 1) <> "" And a(j, 20) <> "BKS PT" Then
                tu = a(j, 20) & a(j, 18) & a(j, 21) & a(j, 25) & a(j, 22)
                If a(j, 25) > active_year - 2 Then
                    If Not (DicoAct2.exists(tu)) Then
                        DicoAct2(tu) = a(j, 16)
                    Else
                        DicoAct2(tu) = DicoAct2(tu) + a(j, 16)
 
                    End If
                End If
            End If
        Next j
    Next i
    Set a = Nothing
 
    nbrarea = DicoIKArea.Count
 
    'crée la table donnée graphique  temporaire
    If FeuilleExiste(ActiveWorkbook, "data_graph") Then
            'SendKeys ("{ENTER}")
            Application.DisplayAlerts = False
            Sheets("data_graph").Delete
            Application.DisplayAlerts = True
    End If
    Sheets.Add
    ActiveSheet.Name = "data_graph"
    Sheets("data_graph").Select
    Cells(1, 1).Select
 
    i = 0
    For Each area In DicoIKArea.keys
    If area <> "Asean" And area <> "Interco" And area <> "Div" And area <> "NL1" And area <> "NL2" And area <> "FR" And area <> "LU" Then
        Sheets("data_graph").Select
        i = i + 1
        posi = (i - 1) * 10 + 1
        resp = DicoIKArea(area)(0)
  '      Worksheets("rp-" & resp).Select
        budaf = DicoIKArea(area)(1)
        budne = DicoIKArea(area)(2)
   '     Dim TabWeek(1 To 53) As Integer
   '     Dim budaf1(1 To 53), budneg1(1 To 53), Neg1(1 To 53), Neg2(1 To 53), Aff1(1 To 53), Aff2(1 To 53) As Double
        Cells(posi, 1) = area
        Cells(posi + 2, 1) = "Bud. Aff."
        Cells(posi + 3, 1) = "Bud. Nég."
        Cells(posi + 4, 1) = "Nég. " & active_year
        Cells(posi + 5, 1) = "Nég. " & prev_year
        Cells(posi + 6, 1) = "Aff. " & active_year
        Cells(posi + 7, 1) = "Aff. " & prev_year
        For j = 1 To 53
 
 
            kkn = "BKS IK" & area & "Neg" & active_year & j
            kkn1 = "BKS IK" & area & "Neg" & prev_year & j
            kka = "BKS IK" & area & "Aff" & active_year & j
            kka1 = "BKS IK" & area & "Aff" & prev_year & j
'            TabWeek(j) = j
            Cells(posi + 1, 1 + j) = j
            If j = 1 Then
                Cells(posi + 2, 1 + j) = budaf / 53       'budget affutage
                Cells(posi + 3, 1 + j) = budne / 53       'budget négoce
            Else
                Cells(posi + 2, 1 + j) = Cells(posi + 2, 1 + j - 1) + budaf / 53   'budget affutage
                Cells(posi + 3, 1 + j) = Cells(posi + 3, 1 + j - 1) + budne / 53  'budget négoce
            End If
            If DicoAct2.exists(kkn) Then
                If j = 1 Then
                    Cells(posi + 4, 1 + j) = DicoAct2(kkn)
                Else
                    Cells(posi + 4, 1 + j) = Cells(posi + 4, 1 + j - 1) + DicoAct2(kkn)
                End If
            Else
                If j = 1 Then
                    Cells(posi + 4, 1 + j) = 0
                Else
                    Cells(posi + 4, 1 + j) = Cells(posi + 4, 1 + j - 1)
                End If
            End If
            If DicoAct2.exists(kkn1) Then
                If j = 1 Then
                    Cells(posi + 5, 1 + j) = DicoAct2(kkn)
                Else
                    Cells(posi + 5, 1 + j) = Cells(posi + 5, 1 + j - 1) + DicoAct2(kkn)
                End If
            Else
                If j = 1 Then
                    Cells(posi + 5, 1 + j) = 0
                Else
                    Cells(posi + 5, 1 + j) = Cells(posi + 5, 1 + j - 1)
                End If
            End If
            If DicoAct2.exists(kka) Then
                If j = 1 Then
                    Cells(posi + 6, 1 + j) = DicoAct2(kkn)
                Else
                    Cells(posi + 6, 1 + j) = Cells(posi + 6, 1 + j - 1) + DicoAct2(kkn)
                End If
            Else
                If j = 1 Then
                    Cells(posi + 6, 1 + j) = 0
                Else
                    Cells(posi + 6, 1 + j) = Cells(posi + 6, 1 + j - 1)
                End If
 
            End If
            If DicoAct2.exists(kka1) Then
                If j = 1 Then
                    Cells(posi + 7, 1 + j) = DicoAct2(kkn)
                Else
                    Cells(posi + 7, 1 + j) = Cells(posi + 7, 1 + j - 1) + DicoAct2(kkn)
                End If
            Else
                If j = 1 Then
                    Cells(posi + 7, 1 + j) = 0
                Else
                    Cells(posi + 7, 1 + j) = Cells(posi + 7, 1 + j - 1)
                End If
 
            End If
        Next j
        '===========================================================
        'génération du graphique d'évolution dans chaque rapport sales
        posi = Worksheets("rp-" & resp).Range("C3").End(xlDown).Row
        Range(Cells((i - 1) * 10 + 2, 1), Cells((i - 1) * 10 + 8, 54)).Select
  '      Rows((i - 1) * 10 + 2 & ":" & (i - 1) * 10 + 8).Select
        Sheets("rp-" & resp).Select
 
        ActiveSheet.Shapes.AddChart.Select
        ActiveChart.ChartType = xlLine
        ActiveChart.SetSourceData Source:=Range("data_graph!$" & (i - 1) * 10 + 2 & ":$" & (i - 1) * 10 + 8)
 
 
        With ActiveChart
 
            .HasTitle = True
            .ChartTitle.Characters.Text = area
        End With
        ActiveChart.Location Where:=xlLocationAsObject, Name:="rp-" & resp
 
        nbG = 0
        For Each Graph In Sheets("rp-" & resp).ChartObjects
            nbG = 1 + nbG
        Next Graph
 
        With ActiveSheet.Shapes(nbG)
            .Width = 600
            .Height = 350
            .Left = Range("A" & (nbG - 1) * 30 + posi + 5).Left
            .Top = Range("A" & (nbG - 1) * 30 + posi + 5).Top
        End With
        ActiveWorkbook.Save
 
 
    End If
    Next area
    DicoAct2.RemoveAll
    DicoIKArea.RemoveAll
    Application.ScreenUpdating = True
End Sub

Excel se bloque si une macro est utilisée plusieurs fois

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager