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
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
| Sub updateAll()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'déclarations des variables
Dim annee As Integer, nbJourMois As Integer
Dim somme As Long, amount As Long
Dim cptJour As Byte, mois As Byte, nbJoursOuvres As Byte, cpt As Byte, i As Byte
Dim premierJourMois As Date, dernierJourMois As Date, nbJourSem As Date
Dim premierJourMoisString As String, derniereCell As String, derniereCellS As String, derniereCellT As String
Dim derniereCellE As String, derniereCellN As String
Dim wb As Workbook
Debug.Print "Début " & Now()
'initialisation de l'année en cours et du mois en cours
annee = Year(Now())
mois = Month(Now())
'construction d'une date à partir de l'année et du mois courants
'ici mois +1 pour ensuite l'utiliser pour connaitre le dernier jour du mois:
'on prend le premier jour du mois suivant puis on enlève un jour
premierJourMoisString = "01/" & mois + 1 & "/" & annee
'détermination du dernier jour du mois à partir de premierJourMoisString
dernierJourMois = Format(DateAdd("d", -1, premierJourMoisString), "yyyy-mm-dd")
'remplacement du premier jour du mois suivant par la date du premier jour du mois en cours
premierJourMoisString = "01/" & mois & "/" & annee
'conversion de la date premierJourMoisString en format date valide
premierJourMois = Format(premierJourMoisString, "yyyy-mm-dd")
'Variable contenant le nombre de jours dans le mois courrant.
nbJourMois = (dernierJourMois - premierJourMois) + 1
'Vérification visuelle des informations
Debug.Print "Premier jour du mois: " & premierJourMois & " Dernier jour du mois: " & dernierJourMois
'Compte le nombre de jours ouvrés (lundi => vendredi) sur le mois
nbJoursOuvres = networkdays(premierJourMois, dernierJourMois)
cpt = 0
i = 1
Workbooks("Synthèse.xls").Activate
With Sheets(1)
For Each c In [J4:J25]
If Month(c) = mois Then
wd = Weekday(c.Value, 2)
Select Case wd
Case 1, 2, 3, 4, 5
cpt = cpt + 1
Case Else
End Select
i = i + 1
End If
Next c
End With
'prise en compte des jours fériés, à opti
nbJoursOuvres = nbJoursOuvres - cpt
'effacement de la zone avant insertion
For Each c In [A4:G27]
c.Value = ""
Next c
'déclaration d 'un compteur servant à vérifier que le nombre de jours ouvrés généré est correct
'il sera incrémenté ensuite à chaque fois qu'un jour ouvré & non férié ou chômé est trouvé et inséré
cptJour = 0
'Boucle servant à déterminer quels jours sont ouvrés, puis les insérer dans une feuille excel
For i = 1 To Format(dernierJourMois, "dd")
'élimine les titres des colonnes des calculs
If (IsNumeric(Cells(cptJour + 3, 3))) Then
trueFalse = True
Else
trueFalse = False
End If
'sélectionne la feuille Synthese
Sheets("Synthese").Activate
Cells(cptJour + 4, 3).Select
ActiveCell.FormulaLocal = "=TRONQUE(J2 / " & nbJoursOuvres & IIf(trueFalse, " + " & Cells(cptJour + 3, 3), "") & ")"
Cells(cptJour + 4, 4).Select
ActiveCell.FormulaLocal = "=TRONQUE(J3 / " & nbJoursOuvres & IIf(trueFalse, " + " & Cells(cptJour + 3, 4), "") & ")"
'compteur servant à vérifier que la date en cours n'est pas une date fériée ou chômée
cpt = 0
'conversion de la date incrémentée (1er au dernier jour du mois) en numéro série
'puis en format date français afin de faciliter la comparaison avec les dates entrées
'en format français
nbJourSem = Format(DateSerial(annee, mois, i), "dd/mm/yyyy")
For Each c In [J4:J25]
If c.Value Like nbJourSem Then
cpt = cpt + 1
End If
Next c
'si la date n'est pas contenu dans la colonne des fériés
If (cpt = 0) Then
'JourSemaine sert à déterminer à quel jour correspond la date générée, le second paramètre
'est le format utilisé, ici le 2 veut dire lundi = premier jour de la semaine
JourSemaine = Weekday(nbJourSem, 2)
'switch, voir lorsque le jour en cours est un jour ouvrable
Select Case JourSemaine
'vérification du jour, lundi => vendredi
Case 1, 2, 3, 4, 5
'Insère les dates générées dans la feuille excel en cours
'qui doit être Synthese
Cells(cptJour + 4, 2).Select
ActiveCell.FormulaR1C1 = nbJourSem
'incrémentation de cptJour, qui détermine le nombre de jours ouvrables traités
cptJour = cptJour + 1
Case Else
End Select
End If
Next i
'met des bordures au tableau utilisé
For Each cellule In Range("B3:G" & cptJour + 3)
cellule.Borders.Weight = xlThin
Next
'vérification que le nombre de jours insérés est correct
Debug.Print "nbJoursOuvres = " & nbJoursOuvres & " cptJour = " & cptJour
cpt = 1
'sert à générer le tableau de recap feuille recapAnnee
'et met les bordures
With Sheets(2)
Sheets(2).Activate
'rempli la colonne des mois
Do While (cpt <= 12)
.Range("B" & cpt + 3).Value = MonthName(cpt, False)
cpt = cpt + 1
Loop
'rempli les titres de colonne
.Range("C3").Value = "PARTS"
.Range("C3").Borders.Weight = xlThin
.Range("D3").Value = "UPGRADE"
.Range("D3").Borders.Weight = xlThin
.Range("E3").Value = "TOTAL"
.Range("E3").Borders.Weight = xlThin
.Range("B16").Value = "TOTAL EN COURS"
.Range("B4:E16").Borders.Weight = xlThin
End With
cpt = 1
'Ouvre le fichier dont les données sont à extraire
Set wb = Workbooks.Open(ThisWorkbook.path & "\FichierSource1.xls")
Workbooks("Synthèse.xls").Sheets(1).Activate
'va chercher les données, compte tenu des jours ouvrés
With Sheets(1)
'parcoure les dates ouvrées
For Each d In Range("B4:B" & cptJour + 3)
j = Format(d, "dd")
m = Format(d, "mm")
'CHANGER
Workbooks("FichierSource1.xls").Activate
'1
'compte la longueur du tableau
derniereCell = Range("S65536").End(xlUp).Row
derniereCellS = "S" & derniereCell - 1
derniereCellT = "T" & derniereCell - 1
With Sheets(1)
'lis les dates et les filtre pour ne garder que les dates du mois
'dont le jour est inférieur à aujourd'hui
For Each c In .Range("T4:" & derniereCellT)
'découpage des dates, pour comparer séparéments les mois et les jours
dayC = Format(c, "dd")
monthC = Format(c, "mm")
dayN = Format(Now(), "dd")
monthN = Format(Now(), "mm")
'vérifie que la date correspond au mois en cours et aux jours précédents celui ci
If (monthN = monthC And dayC < dayN) Then
'vérifie que la date est bien ouvrée
'et compte le montant des transactions
If (j = dayC And m = monthC) Then
tot = Range("S" & c.Row)
TotJour = TotJour + tot
typeClt = Range("D" & c.Row)
'regarde si il s'agit d'une transaction interne
'si oui, compte le montant
If (typeClt = "Internal") Then
totInt = totInt + tot
End If
End If
End If
Next c
'incrémente le jour ouvré
cpt = cpt + 1
End With
Workbooks("Synthèse.xls").Sheets(1).Activate
'insère les valeurs en k$
If (Format(Range("B" & cpt + 2).Value, "dd-mm-yyyy") < Format(Now(), "dd-mm-yyyy")) Then
Range("E" & cpt + 2).FormulaLocal = "=ARRONDI(" & TotJour & ";-3)/1000"
Range("F" & cpt + 2).FormulaLocal = "=ARRONDI(" & totInt & ";-3)/1000"
End If
Next d
'compte les transactions internes en %
For Each lol In Range("G4:G" & cptJour + 3)
lol.FormulaLocal = "=SI(ESTERR(ARRONDI(" & Range("F" & lol.Row).Value & "/" & Range("E" & lol.Row).Value & "*100;2)),"", ARRONDI(" & Range("F" & lol.Row).Value & "/" & Range("E" & lol.Row).Value & "*100;2))"
Next lol
End With
Set wb = Workbooks.Open(ThisWorkbook.path & "\FichierSource2.xls")
'sert à compter les upgrades
With Workbooks("FichierSource2.xls").Sheets(1)
'détermine la dernière ligne utilisée
derniereCell = .Range("E65536").End(xlUp).Row
derniereCellE = "E" & derniereCell - 1
derniereCellN = "N" & derniereCell - 1
'sert à insérer les montants par mois
For cpt = 1 To Format(Now(), "mm")
Workbooks("FichierSource2.xls").Activate
amount = 0
'parcoure le fichier et prend les montants
For Each a In Range("E4:" & derniereCellE)
moisC = MonthName(Format(a, "mm"), True)
monthN = MonthName(cpt, True)
'vérifie que le mois en cours (via cpt) correspond au mois de la cellule
If (monthN = moisC) Then
'prend les données de la colonne N correspondant à la cellule parcourue
amount = amount + Range("N" & a.Row)
End If
Next a
'insère le montant dans le fichier cible
Workbooks("Synthèse.xls").Activate
Sheets(2).Range("D" & cpt + 3) = amount
Sheets(2).Range("D" & cpt + 3).Borders.Weight = xlThin
Next cpt
End With
Set wb = Workbooks.Open(ThisWorkbook.path & "\FichierSource1.xls")
wb.Worksheets(1).Activate
'détermine la dernière ligne utilisée
derniereCell = Range("S65536").End(xlUp).Row
derniereCellS = "S" & derniereCell - 1
derniereCellT = "T" & derniereCell - 1
'initialise la somme
somme = 0
'sert à calculer le total des ventes pour chaque mois
For cpt = 1 To 12
totMois = 0
'prend les montants du mois
For Each c In Range("T4:" & derniereCellT)
If (cpt = Month(c)) Then
totMois = totMois + Range("S" & c.Row).Value
End If
Next c
'arrondi le montant
totMois = Round(totMois, 0)
'insère les données des mois
With Workbooks("Synthèse.xls").Sheets(2)
.Range("C" & cpt + 3).Value = totMois
.Range("C" & cpt + 3).Borders.Weight = xlThin
End With
Next cpt
'calcule le total de l'année
For Each c In Range("S4:" & derniereCellS)
somme = somme + c
Next c
'insère le montant de l'année
With Workbooks("Synthèse.xls").Sheets(2)
.Range("C16").Value = somme
.Range("C16").Borders.Weight = xlThin
End With
'calcule le total pour chaque mois
With Workbooks("Synthèse.xls").Sheets(2)
Workbooks("Synthèse.xls").Sheets(2).Activate
For Each c In Range("E4:E16")
'Debug.Print c
c.Value = Range("C" & c.Row) + Range("D" & c.Row)
c.Borders.Weight = xlThin
Next c
End With
'remet en route l'affichage
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Debug.Print "finish " & Now()
End Sub |
Optimisation de code
)
Répondre avec citation
Partager