Somme de valeur suivant condition sur cellule

**EricBOG** · 15/07/2013, 10h09

Bonjour à tous,

J'ai un petit probleme de macro VBA. En fait j'ai réussi à écrire un code qui fonctionne, mais qui prend beaucoup trop de temps au niveau de l'execution.

Voila la description de l'algorithme que je souhaite executer.

Dans le tableau 1, j'ai environ 30 lignes (1 par date, le tableau regroupant les données d'un mois).
La première colonne indique la date.
En ligne d'en-tête de ce tableau sont indiquées pour chaque colonne 4 informations (exemple: Entry Baumgarten FZK Sold). Il y a environ 150 colonnes représentant chacune une combinaison d'information différente de ces 4 paramètres.

Dans un autre tableau, le tableau 2, j'ai la première colonne indique également la date (jour). Ensuite, d'autres colonnes indiquent les informations suivantes: Direction (Entry ou Exit) - Point (ex Baumgarten) - Type de Capacité (ex FZK ou DZK ou UK) - Montant du contrat (Sold) - Nom du contrat
Dans ce tableau 2, les contrats sont éclatés par jour et par bénéficiaire. Cela signifie quùn contrat d'une durée d'une semaine bénéficiant à deux bénéficiaires comportera 14 lignes (1 Semaine = 7 lignes x 2 car nbre de bénéficiare = 2).
Il y a 35000 lignes dans le 2nd tableau. Et oui un bon paquet d'où la lenteur d'execution avec un programme non optimisé.

Ce que je veux faire:
Chaque valeur du tableau1, qui correspond à un montant de contrat donné à une date (colonne1) et une direction, un point, un type de capacité (colonne n), doit être comparé à la somme de tous les contrats correspondants à ces 4 paramètres (jour/Direction/Point/Type de capacité) du tableau2.
Il est donc nécessaire de repérer les lignes avec ces 4 paramètres et de faire la somme de l'ensemble des valeurs de la colonnes contrats lorsque les 4 conditions sont remplies.
Problème, étant donné qu'un contrat peu avoir plusieurs bénéficiaires, il faut s'assurer de ne pas comptabiliser plusieurs fois la valeur du contrat. Il faut donc faire un test sur le nom du contrat et ne comptabiliser qu'une seule fois le montant du contrat en cas de nom identique.

De mon côté, comme je l'indiquait initialement, j'ai écrit un code très basique qui consiste à lire les 4 informations de chaque case du tableau1, les comparer aux informations des en-têtes des colonnes du tableau2 (on ne rentre dans la boucle uniquement si les conditions sont respectées, avec des tests successifs sur les 4 informations).
Si les 4 conditions sont remplies, alors on fait un dernier test en lisant le nom du contrat du tableau2 et en le comparant à tous les noms des contrats des lignes précédentes, déja traités. Si le contrat n'est pas encore apparu, alors il place la valeur de la colonne Montant du contrat dans un buffer qui est incrémenté du nouveau montant à chaque nouvelle valeur à prendre en compte.
Une fois arrivé tout en bas, je compare le buffer avec la valeur du tableau1. Et c'est terminé.

Etant donné que je suis un débutant, j'ai écrit mon code basiquement avec des boucles imbriquées en if et en while. Ca fonctionne, mais ce n'est pour cette raison que le programme n'est pas performant.

J'en appelle donc aux experts de ce forum, pour m'indiquer les fonctions à utiliser permettant de gagner en temps d'exectution de la macro.

Merci à tous!

Eric

**SMBeccaria** · 15/07/2013, 10h48

Bonjour ,

Pouvez-vous poster le fichier avec votre procédure je veux bien y jeter un oeil ?

cdt

**EricBOG** · 15/07/2013, 11h31

Bonjour et merci de bien vouloir y jeter un oeil. Le fichier est en PJ. J'ai supprimé qques donnés qui sont confidentielles.
Le tableau1 est l'onglet "Consolidated GMS Data" et le Tableau2 est "Data Contract 2013"

Et voici mon code ci-dessous pour la partie en question.
PS: Pour essyer de gagner du temps, j'utilisais une feuille "Contract Buffer" dans laquelle je ne copiait que les données du mois concerné, ceci afin d'éviter de passer en revue inutilement toutes les lignes de la feuille "Data Contract 2013".

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
Sub StartMacroCompGMSMAM()
'-----------------------------------------------------------------------------
'Declarations
'-----------------------------------------------------------------------------
Dim wb As Workbook
Dim wsMAM As Worksheet
Dim wsCOMP As Worksheet
Dim wsGMS As Worksheet
Dim wsTEST As Worksheet
 
Dim Compteurjour As Double
Dim Compteurheure As Double
 
Dim dLigneOffset As Double
Dim dColumnOffset As Double
 
Dim GMSBuffer As Double
Dim LigneBuffer As Double
Dim MamRowIndex As Double
Dim MamLineIndex As Double
 
Dim RefMAM As Variant
Dim DateMAM As String
 
'-----------------------------------------------------------------------------
'Settings
'-----------------------------------------------------------------------------
'First row to import data.
dLigneOffset = 3
dColumnOffset = 1
 
'Set workbook.
Set wb = Me.Application.ActiveWorkbook
Set wsMAM = wb.Worksheets("Data Raw MAM Platform")
Set wsCOMP = wb.Sheets("Consolidated GMS Data")
Set wsGMS = wb.Sheets("Data Processed GMS")
'Set wsBUF = wb.Sheets("Data Contract Buffer")
 
 
'        If RefMAM(3) = "Sold" Then
'        GMSBuffer = 0
'            If wsBUF.Cells(LigneBuffer, 1) = wsCOMP.Cells(MamLineIndex, 1) Then
'                If wsBUF.Cells(LigneBuffer, 10).Value = RefMAM(0) Then
'                    If wsBUF.Cells(LigneBuffer, 13).Value = RefMAM(1) Then
'                        If wsBUF.Cells(LigneBuffer, 16).Value = RefMAM(2) Then
'                            GMSBuffer = wsBUF.Cells(LigneBuffer, 3).Value * 24 + GMSBuffer
'                        End If
'                    End If
'                End If
'            End If
'
'            LigneBuffer = LigneBuffer + 1
'
'            For LigneBuffer = 4 To wsBUF.Cells(65536, 1).End(xlUp).Row
'                CritereArret = False
'                Datum = wsBUF.Cells(LigneBuffer, 1)
'                Contract = wsBUF.Cells(LigneBuffer, 5)
'                For LigneBufferRange = LigneBuffer - 1 To 3 Step -1
'                    If wsBUF.Cells(LigneBufferRange, 1).Value = Datum And wsBUF.Cells(LigneBufferRange, 5).Value = Contract Then
'                        CritereArret = True
'                        Exit For
'                    End If
'                Next LigneBufferRange
'                If CritereArret = False Then
'                   If wsBUF.Cells(LigneBuffer, 1) = wsCOMP.Cells(MamLineIndex, 1) Then
'                        If wsBUF.Cells(LigneBuffer, 10).Value = RefMAM(0) Then
'                            If wsBUF.Cells(LigneBuffer, 13).Value = RefMAM(1) Then
'                                If wsBUF.Cells(LigneBuffer, 16).Value = RefMAM(2) Then
'                                    GMSBuffer = wsBUF.Cells(LigneBuffer, 3).Value * 24 + GMSBuffer
'                                End If
'                            End If
'                        End If
'                    End If
'                End If
'            Next LigneBuffer
'
'            If wsCOMP.Cells(MamLineIndex, MamRowIndex).Value = GMSBuffer Then
'                wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 50
'                Else: wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 46
'            End If
'        End If
 
        MamRowIndex = MamRowIndex + 1
        Wend
 
    MamLineIndex = MamLineIndex + 1
    MamRowIndex = 2
    Wend
 
End Sub

Invité · 15/07/2013, 11h34

voila pour les balises!

Code :

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

1
2
3
Sub StartMacroCompGMSMAM()
 
End Sub

Mais c’est bien, tu veux mètre les balises de code [#], mais tu n’as pas compris le système.

**SMBeccaria** · 15/07/2013, 14h44

Il ne manque pas quelques lignes de codes ?

Certaines variables ne sont pas initialisées et RefMAM n'est pas dimensionnée comme un tableau, la procédure ne peut pas marcher.

**EricBOG** · 15/07/2013, 15h27

Si probablement, car j'ai supprimé tte une partie du code qui traite d'autres données, histoire de ne pas vous enbrouiller trop.

Voici le code en entier, tout en sachant que seule la partie finale concerne le traitement qui me pose problème (celle qui est avec un apostrophe car je fais pour le moment tourner ma macro sans cette partie). Les parties antérieures fonctionnent très bien et dans un temps raisonnable.

Merci pour ton aide!

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
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
Sub StartMacroCompGMSMAM()
'-----------------------------------------------------------------------------
'Declarations
'-----------------------------------------------------------------------------
Dim wb As Workbook
Dim wsMAM As Worksheet
Dim wsCOMP As Worksheet
Dim wsGMS As Worksheet
Dim wsTEST As Worksheet
 
Dim Compteurjour As Double
Dim Compteurheure As Double
 
Dim dLigneOffset As Double
Dim dColumnOffset As Double
 
Dim GMSBuffer As Double
Dim LigneBuffer As Double
Dim MamRowIndex As Double
Dim MamLineIndex As Double
 
Dim RefMAM As Variant
Dim DateMAM As String
 
'-----------------------------------------------------------------------------
'Settings
'-----------------------------------------------------------------------------
'First row to import data.
dLigneOffset = 3
dColumnOffset = 1
 
'Set workbook.
Set wb = Me.Application.ActiveWorkbook
Set wsMAM = wb.Worksheets("Data Raw MAM Platform")
Set wsCOMP = wb.Sheets("Consolidated GMS Data")
Set wsGMS = wb.Sheets("Data Processed GMS")
'Set wsBUF = wb.Sheets("Data Contract Buffer")
 
'-----------------------------------------------------------------------------
'Code 1
'-----------------------------------------------------------------------------
 
'Errase Data
wsCOMP.Range("A3:EK40").ClearContents
wsCOMP.Range("A3:EK40").Interior.ColorIndex = 0
 
'Calculation of the daily values
 
Compteurjour = dLigneOffset
Compteurheure = dLigneOffset
 
    While Not (IsEmpty(wsMAM.Cells(Compteurheure, 1)))
 
    dColumnOffset = 1
    wsCOMP.Cells(Compteurjour, dColumnOffset).Value = Left(wsMAM.Cells(Compteurheure, dColumnOffset).Text, 10)
    dColumnOffset = dColumnOffset + 1
 
        While Not dColumnOffset = 142
            If dColumnOffset = 63 Or dColumnOffset = 64 Or dColumnOffset = 65 Or dColumnOffset = 66 Or dColumnOffset = 88 Or dColumnOffset = 89 Or dColumnOffset = 90 Or dColumnOffset = 91 Or dColumnOffset = 113 Or dColumnOffset = 114 Or dColumnOffset = 115 Or dColumnOffset = 116 Or dColumnOffset = 138 Or dColumnOffset = 139 Or dColumnOffset = 140 Or dColumnOffset = 141 Then
                With wsMAM
                wsCOMP.Cells(Compteurjour, dColumnOffset).Value = Application.WorksheetFunction.Sum(.Range(.Cells(Compteurheure, dColumnOffset), .Cells(Compteurheure + 23, dColumnOffset))) / 24
                End With
            Else
                With wsMAM
                wsCOMP.Cells(Compteurjour, dColumnOffset).Value = Application.WorksheetFunction.Sum(.Range(.Cells(Compteurheure, dColumnOffset), .Cells(Compteurheure + 23, dColumnOffset)))
                End With
            End If
        dColumnOffset = dColumnOffset + 1
        Wend
 
    Compteurheure = Compteurheure + 24
    Compteurjour = Compteurjour + 1
 
    Wend
 
 
 
'Copy the alloted capacity data
 
    MamRowIndex = 2
    MamLineIndex = 3
 
    While Not (IsEmpty(wsCOMP.Cells(MamLineIndex, MamRowIndex)))
 
        While Not (IsEmpty(wsCOMP.Cells(2, MamRowIndex)))
 
        RefMAM = Split(wsCOMP.Cells(2, MamRowIndex), " ")
        LigneBuffer = 3
        GMSBuffer = 0
 
        If RefMAM(3) = "Nominated" Then
            While Not (IsEmpty(wsGMS.Cells(LigneBuffer, 1)))
                If wsGMS.Cells(LigneBuffer, 1) = wsCOMP.Cells(MamLineIndex, 1) Then
                    If wsGMS.Cells(LigneBuffer, 4).Value = RefMAM(0) Then
                        If wsGMS.Cells(LigneBuffer, 3).Value = RefMAM(1) Then
                            If wsGMS.Cells(LigneBuffer, 5).Value = RefMAM(2) Then
                            GMSBuffer = wsGMS.Cells(LigneBuffer, 8).Value + GMSBuffer
                            End If
                        End If
                    End If
                End If
                LigneBuffer = LigneBuffer + 1
            Wend
 
            If wsCOMP.Cells(MamLineIndex, MamRowIndex).Value = GMSBuffer Then
                wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 50
                Else: wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 46
            End If
        End If
 
        If RefMAM(3) = "Renominated" Then
            While Not (IsEmpty(wsGMS.Cells(LigneBuffer, 1)))
                If wsGMS.Cells(LigneBuffer, 1) = wsCOMP.Cells(MamLineIndex, 1) Then
                    If wsGMS.Cells(LigneBuffer, 4).Value = RefMAM(0) Then
                        If wsGMS.Cells(LigneBuffer, 3).Value = RefMAM(1) Then
                            If wsGMS.Cells(LigneBuffer, 5).Value = RefMAM(2) Then
                            GMSBuffer = wsGMS.Cells(LigneBuffer, 9).Value + GMSBuffer
                            End If
                        End If
                    End If
                End If
                LigneBuffer = LigneBuffer + 1
            Wend
 
            If wsCOMP.Cells(MamLineIndex, MamRowIndex).Value = GMSBuffer Then
                wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 50
                Else: wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 46
            End If
        End If
 
        If RefMAM(3) = "Used" Then
            While Not (IsEmpty(wsGMS.Cells(LigneBuffer, 1)))
                If wsGMS.Cells(LigneBuffer, 1) = wsCOMP.Cells(MamLineIndex, 1) Then
                    If wsGMS.Cells(LigneBuffer, 4).Value = RefMAM(0) Then
                        If wsGMS.Cells(LigneBuffer, 3).Value = RefMAM(1) Then
                            If wsGMS.Cells(LigneBuffer, 5).Value = RefMAM(2) Then
                            GMSBuffer = wsGMS.Cells(LigneBuffer, 10).Value + GMSBuffer
                            End If
                        End If
                    End If
                End If
                LigneBuffer = LigneBuffer + 1
            Wend
 
            If wsCOMP.Cells(MamLineIndex, MamRowIndex).Value = GMSBuffer Then
                wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 50
                Else: wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 46
            End If
        End If
 
'        If RefMAM(3) = "Sold" Then
'        GMSBuffer = 0
'            If wsBUF.Cells(LigneBuffer, 1) = wsCOMP.Cells(MamLineIndex, 1) Then
'                If wsBUF.Cells(LigneBuffer, 10).Value = RefMAM(0) Then
'                    If wsBUF.Cells(LigneBuffer, 13).Value = RefMAM(1) Then
'                        If wsBUF.Cells(LigneBuffer, 16).Value = RefMAM(2) Then
'                            GMSBuffer = wsBUF.Cells(LigneBuffer, 3).Value * 24 + GMSBuffer
'                        End If
'                    End If
'                End If
'            End If
'
'            LigneBuffer = LigneBuffer + 1
'
'            For LigneBuffer = 4 To wsBUF.Cells(65536, 1).End(xlUp).Row
'                CritereArret = False
'                Datum = wsBUF.Cells(LigneBuffer, 1)
'                Contract = wsBUF.Cells(LigneBuffer, 5)
'                For LigneBufferRange = LigneBuffer - 1 To 3 Step -1
'                    If wsBUF.Cells(LigneBufferRange, 1).Value = Datum And wsBUF.Cells(LigneBufferRange, 5).Value = Contract Then
'                        CritereArret = True
'                        Exit For
'                    End If
'                Next LigneBufferRange
'                If CritereArret = False Then
'                   If wsBUF.Cells(LigneBuffer, 1) = wsCOMP.Cells(MamLineIndex, 1) Then
'                        If wsBUF.Cells(LigneBuffer, 10).Value = RefMAM(0) Then
'                            If wsBUF.Cells(LigneBuffer, 13).Value = RefMAM(1) Then
'                                If wsBUF.Cells(LigneBuffer, 16).Value = RefMAM(2) Then
'                                    GMSBuffer = wsBUF.Cells(LigneBuffer, 3).Value * 24 + GMSBuffer
'                                End If
'                            End If
'                        End If
'                    End If
'                End If
'            Next LigneBuffer
'
'            If wsCOMP.Cells(MamLineIndex, MamRowIndex).Value = GMSBuffer Then
'                wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 50
'                Else: wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 46
'            End If
'        End If
 
        MamRowIndex = MamRowIndex + 1
        Wend
 
    MamLineIndex = MamLineIndex + 1
    MamRowIndex = 2
    Wend
 
End Sub
 
Sub StartMacroExportData()
 
Dim wb As Workbook
Dim OpenWb As Workbook
Set wb = ActiveWorkbook
Set OpenWb = Workbooks.Open("\\homedrives.bog.net\doueri1\Documents\Business Dispatching Data Process\Business Dispatching Analysis.xlsm")
 
With OpenWb.Sheets("Comparison MAM-GMS")
.Range(.Range("A1"), .Cells(.Range("A65536").End(xlUp).Row, .Range("A2").End(xlToRight).Column)).Interior.ColorIndex = 0
.Range(.Range("A1"), .Cells(.Range("A65536").End(xlUp).Row, .Range("A2").End(xlToRight).Column)).ClearContents
wb.Sheets("Consolidated GMS Data").Cells.Copy .Range("A1")
End With
 
With OpenWb.Sheets("Contract")
.Range(.Range("A1"), .Cells(.Range("A65536").End(xlUp).Row, .Range("A2").End(xlToRight).Column)).ClearContents
wb.Sheets("Data Contract Type").Cells.Copy .Range("A1")
End With
 
With OpenWb.Sheets("Contract 2013")
.Range(.Range("A1"), .Cells(.Range("A65536").End(xlUp).Row, .Range("A2").End(xlToRight).Column)).ClearContents
wb.Sheets("Data Contract 2013").Cells.Copy .Range("A1")
End With
 
With OpenWb.Sheets("Contract >2013")
.Range(.Range("A1"), .Cells(.Range("A65536").End(xlUp).Row, .Range("A2").End(xlToRight).Column)).ClearContents
wb.Sheets("Data Contract 2014").Cells.Copy .Range("A1")
End With
 
With OpenWb.Sheets("Nomination")
.Range(.Range("A1"), .Cells(.Range("A65536").End(xlUp).Row, .Range("A2").End(xlToRight).Column)).ClearContents
wb.Sheets("Data Processed GMS").Cells.Copy .Range("A1")
End With
 
End Sub

**SMBeccaria** · 16/07/2013, 10h41

J'avoue que je n'aurai pas fonctionné comme cela, mais pourquoi ne pas garder le même format pour votre itération sur le critère "Sold" que pour les autres ?

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
 
        If RefMAM(3) = "Sold" Then
        GMSBuffer = 0
            While Not (IsEmpty(wsGMS.Cells(LigneBuffer, 1)))
                If wsGMS.Cells(LigneBuffer, 1) = wsCOMP.Cells(MamLineIndex, 1) Then
                    If wsGMS.Cells(LigneBuffer, 10).Value = RefMAM(0) Then
                        If wsGMS.Cells(LigneBuffer, 13).Value = RefMAM(1) Then
                            If wsGMS.Cells(LigneBuffer, 16).Value = RefMAM(2) Then
                                GMSBuffer = wsBUF.Cells(LigneBuffer, 3).Value * 24 + GMSBuffer
                            End If
                        End If
                    End If
                End If
                LigneBuffer = LigneBuffer + 1
            Wend
 
            If wsCOMP.Cells(MamLineIndex, MamRowIndex).Value = GMSBuffer Then
                wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 50
                Else: wsCOMP.Cells(MamLineIndex, MamRowIndex).Interior.ColorIndex = 46
            End If
        End If

Cela semble donner des résultats conformes relativement aux autres critères non ?

**EricBOG** · 16/07/2013, 11h30

En fait, les autres critères se basent sur des montants propres aux "Balancing Groups" et la différence est qu'une ligne = un montant unique.
Alors que pour "sold", le critère est sur le contrat et que dans ce cas, il peut y avoir des doublons de ligne, dans le cas ou un contrat ait été eclaté sur plusieur balancing group.
En fait chaque ligne indique le montant global du contrat et la part attribuée au Balancing Group concerné. Et vu que la somme des parts attribuées pour un même contrat n'est pas obligatoirement le montant global du contrat, on ne peut pas faire autrement.

Mais bon, j'ai trouvé un moyen de raccourcir le temps de traitement qui devient acceptable.
Je traite le probleme à la source, sur la liste des contrats en supprimant tous les doublons. De ce fait, lorsque de les éclate par jour, j'ai un nombre considérable de ligne en moins (je passe à moins de 20000) et de plus plus de doublon!

Merci qd même d'avoir planché sur le problème!
Et si qqun connait une fonction magique de recherche plutot que mes n boucles, je reste tjs preneur.

Ciao. Eric

Somme de valeur suivant condition sur cellule [XL-2010]

Macros et VBA Excel

Discussions similaires

Partager

Partager