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
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
| Sub RapportBudget(Annee As Integer)
'déclaration des objets excel
Dim oAppExcell As Object
Dim oClasseur As Object
Dim oFeuille As Object
Dim oCell As Object
Dim oRange As Object
Dim oRow As Object
'déclaration varaibles liées au tpe de comptes
Dim szTypeCompte As String
Dim nTypeCompte As Integer
'divers
Dim szChemin As String
Dim Colone As Integer
Dim Colone2 As Integer
Dim Ligne As Integer
Dim ColoneMois As Integer
Dim LigneFinTab As Integer
Dim Ligne2 As Integer
'Dim Legende As String
'déclaration recordset
Dim rstDernierMois As DAO.Recordset
Dim rstDepense As DAO.Recordset
Dim rstDepenseCompte As DAO.Recordset
Dim rstBudgetPrimitif As DAO.Recordset
'déclaration requête pour recordset
Dim SQL As String
Dim szSqlCompte As String
Dim szSqlCritere As String
Dim szSqlCriterePrimitif As String
'déclaration compteurs pour boucles
Dim Cpte As Integer
Dim i As Integer
Dim k As Integer
Dim szDernierMois As String
'déclaration parametres
'instanciation de paramètres
Dim xlcenter As Integer
Dim xlContinuous As Integer
Dim xlMedium As Integer
Dim xlAutomatic As Integer
Dim xlSolid As Integer
Dim xlUnderlineStyleNone As Integer
Dim xlNone As Integer
Dim xlThin As Integer
Dim NomFichier As String
xlThin = 2
xlcenter = 2
xlContinuous = 1
xlMedium = 3
xlAutomatic = 1
xlSolid = 1
xlUnderlineStyleNone = 1
xlNone = 0
'demande d'emplacement de fichier excel
NomFichier = "Budget_" & Year(Date)
'szChemin = Directory_FileSave.SaveFile("Sélection fichier modele", NomFichier)
DoCmd.OpenForm "frm_Patientez", acNormal, , , acFormReadOnly, acWindowNormal
'instanciation des objets
Set oAppExcell = CreateObject("Excel.Application")
Set oClasseur = oAppExcell.Workbooks.Add
Set oFeuille = oClasseur.sheets(1)
'Taille des collonnes
oFeuille.Columns("D:Q").ColumnWidth = 10.71
oFeuille.Columns("A:A").ColumnWidth = 8.14
oFeuille.Columns("B:B").ColumnWidth = 10
oFeuille.Columns("C:C").ColumnWidth = 11
oFeuille.Columns("R:R").ColumnWidth = 8.43
LigneFinTab = 1
Set rstDernierMois = CurrentDb.OpenRecordset("T_Parametres", dbOpenDynaset, dbReadOnly)
Set rstBudgetPrimitif = CurrentDb.OpenRecordset("T_Budget_Primitif", dbOpenDynaset, dbReadOnly)
rstDernierMois.MoveFirst
szDernierMois = rstDernierMois![nDernierMoisBudgetMAJ]
' création des 3 tableaux de comptes (chaque boucle un tableau différent)
For Cpte = 1 To 3
Select Case Cpte
Case 1
szTypeCompte = "Fonctionnement"
nTypeCompte = 6
Case 2
szTypeCompte = "Investissement"
nTypeCompte = 2
Case 3
szTypeCompte = "Tiers"
nTypeCompte = 4
End Select
szSqlCompte = " SELECT T_Budget_Depense.NumeroCompte FROM T_Budget_Depense WHERE (((T_Budget_Depense.Annee) = " & Annee & "))GROUP BY T_Budget_Depense.NumeroCompte, Left([NumeroCompte],1), Left([NumeroCompte],3) HAVING (((Left([NumeroCompte], 1)) =" & nTypeCompte & "))ORDER BY Left([NumeroCompte],3)"
Set rstDepenseCompte = CurrentDb.OpenRecordset(szSqlCompte, dbOpenDynaset, dbReadOnly)
'Mise en place d'un titre
Colone = 1
Colone2 = 4
Ligne = LigneFinTab + 2
Ligne2 = LigneFinTab + 3
Set oRange = oFeuille.Range(Chr(Colone + 64) & Ligne & ":" & Chr(Colone2 + 64) & Ligne2)
oRange.merge
oRange.Value = "Comptes " & szTypeCompte
With oRange
.Font.Bold = True
.Font.Size = 16
.Font.Color = vbBlue
.WrapText = True
.HorizontalAlignment = 3
.VerticalAlignment = 2
With .Borders(2)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(3)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(4)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(1)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With
Ligne = Ligne2 + 2
Ligne2 = Ligne2 + 2
Colone = 2
Colone2 = 3
Set oRange = oFeuille.Range(Chr(Colone + 64) & Ligne & ":" & Chr(Colone2 + 64) & Ligne2)
oRange.merge
'Remplis les entêtes du tableau
For Colone = 1 To 18
Set oCell = oFeuille.Cells(Ligne, Colone)
Select Case Colone
Case 1
oCell.Value = "Nature des dépenses"
Case 2
oCell.Value = "Numéro de compte"
Case 4
oCell.Value = "Janvier"
Case 5
oCell.Value = "Février"
Case 6
oCell.Value = "Mars"
Case 7
oCell.Value = "Avril"
Case 8
oCell.Value = "Mai"
Case 9
oCell.Value = "juin"
Case 10
oCell.Value = "Juillet"
Case 11
oCell.Value = "Août"
Case 12
oCell.Value = "Septembre"
Case 13
oCell.Value = "Octobre"
Case 14
oCell.Value = "Novembre"
Case 15
oCell.Value = "Décembre"
Case 16
oCell.Value = "Budget Courant"
Case 17
oCell.Value = "Budget Primitif"
Case 18
oCell.Value = "Evolution du Budget"
End Select
With oCell
.Font.Bold = False
.Font.Size = 10
.Font.Color = vbWhite
.WrapText = True
.RowHeight = 40.5
.Interior.ColorIndex = 39
.Interior.Pattern = xlSolid
.HorizontalAlignment = 3
.VerticalAlignment = 2
With .Borders(2)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(3)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(4)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(1)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With
Next
Colone2 = Colone
Colone = 1
rstDepenseCompte.MoveFirst
'parcour les comptes
Ligne = LigneFinTab + 5
While Not rstDepenseCompte.EOF
SQL = "SELECT T_Budget_Depense.*, T_Budget_Depense.NumeroCompte FROM T_Budget_Depense WHERE ((( T_Budget_Depense.NumeroCompte = " & rstDepenseCompte![NumeroCompte] & " ANd T_Budget_Depense.Annee = " & Annee & ")))"
Set rstDepense = CurrentDb.OpenRecordset(SQL, dbOpenDynaset, dbReadOnly)
Set oCell = oFeuille.Cells(Ligne + 1, 2)
Colone = 2
Colone2 = 2
Ligne2 = Ligne + 7
Set oRange = oFeuille.Range(Chr(Colone + 64) & Ligne + 1 & ":" & Chr(Colone2 + 64) & Ligne2)
oRange.merge
Colone = 1
Colone2 = 18
With oRange
.Font.Color = vbWhite
.Interior.ColorIndex = 47
End With
Set oRange = oFeuille.Range(Chr(Colone + 64) & Ligne + 1 & ":" & Chr(Colone2 + 64) & Ligne2)
oCell.Value = rstDepenseCompte![NumeroCompte]
oCell.NumberFormat = "General"
'******Mise En Page De la cellule NumCompte
With oRange
.HorizontalAlignment = 3
.VerticalAlignment = 2
.WrapText = True
.Orientation = 0
.ShrinkToFit = False
End With
With oRange.Font
.Name = "Arial"
.FontStyle = "Normal"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
oRange.Borders(2).LineStyle = xlNone
oRange.Borders(1).LineStyle = xlNone
With oRange.Borders(1)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oRange.Borders(2)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oRange.Borders(3)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With oRange.Borders(4)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
oRange.Borders(12).Weight = xlThin
'Fin Mise en page cellule Num compta
' cellule Budget Courant
Colone = 16
Colone2 = 16
szSqlCritere = "Mois = '" & szDernierMois & "'"
rstDepense.FindFirst (szSqlCritere)
If rstDepenseCompte.NoMatch Then
MsgBox " le compte " & rstDepense![NumeroCompte] & "n'a pas été mis à jour , relancez une MAJ des comptes si vous désirez voir apparaitre le budget courant et les calculs y référents"
Else
Set oRange = oFeuille.Range(Chr(Colone + 64) & Ligne + 1 & ":" & Chr(Colone2 + 64) & Ligne2)
oRange.merge
oRange.Value = rstDepense![Credits]
oRange.NumberFormat = "#,##0.00 $"
End If
'Fin Mise en page cellule BudgetCourant
oRange.Copy
' cellule Budget Primitif
Colone = 17
Colone2 = 17
szSqlCriterePrimitif = "Annee = " & Annee & " and NumeroCpte = " & rstDepenseCompte![NumeroCompte]
rstBudgetPrimitif.FindFirst (szSqlCriterePrimitif)
Set oRange = oFeuille.Range(Chr(Colone + 64) & Ligne + 1 & ":" & Chr(Colone2 + 64) & Ligne2)
oRange.merge
If rstBudgetPrimitif.NoMatch Then
Else
oRange.Value = rstBudgetPrimitif![Crédits]
oRange.NumberFormat = "#,##0.00 $"
End If
'Fin Mise en page cellule BudgetPrimitif
' cellule Intitule Compte
Colone = 1
Colone2 = 1
szSqlCriterePrimitif = "Annee = " & Annee & " and NumeroCpte = " & rstDepenseCompte![NumeroCompte]
rstBudgetPrimitif.FindFirst (szSqlCriterePrimitif)
Set oRange = oFeuille.Range(Chr(Colone + 64) & Ligne + 1 & ":" & Chr(Colone2 + 64) & Ligne2)
oRange.merge
If rstBudgetPrimitif.NoMatch Then
Else
oRange.Value = rstBudgetPrimitif![IntituleCpte]
End If
With oRange
.HorizontalAlignment = 3
.VerticalAlignment = xlcenter
.WrapText = True
.Orientation = 90
.ShrinkToFit = False
.MergeCells = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 47
End With
'Fin Mise en page cellule Intitule Compte
' cellule Budget Diférentiel
Colone = 18
Colone2 = 18
szSqlCriterePrimitif = "Annee = " & Annee & " and NumeroCpte = " & rstDepenseCompte![NumeroCompte]
Set oRange = oFeuille.Range(Chr(Colone + 64) & Ligne + 1 & ":" & Chr(Colone2 + 64) & Ligne2)
oRange.merge
oRange.NumberFormat = "0"
oRange.Formulalocal = "=Si(" & Chr(Colone - 2 + 64) & Ligne + 1 & "= 0;;Si( " & Chr(Colone - 1 + 64) & Ligne + 1 & "=0;;(" & Chr(Colone - 2 + 64) & Ligne + 1 & "-" & Chr(Colone - 1 + 64) & Ligne + 1 & ")/" & Chr(Colone - 1 + 64) & Ligne + 1 & "))"
'Fin Mise en page cellule DiférentielBudget
For i = 1 To 7
' k = k + 1
Ligne = Ligne + 1
Set oCell = oFeuille.Cells(Ligne, 3)
oCell.Value = rstDepenseCompte![NumeroCompte]
Select Case i
Case 1
oCell.Value = "Engagement Mensuel"
Case 2
oCell.Value = " Engagement cumulé"
Case 3
oCell.Value = " % Engagé / Budget"
Case 4
oCell.Value = "Pré-mandaté mensuel"
Case 5
oCell.Value = "Pré-mandaté cumulé"
Case 6
oCell.Value = "% Pré-mandaté / Budget"
Case 7
oCell.Value = "Disponibilité"
End Select
oCell.NumberFormat = "General"
oCell.Font.Size = 10
Next
rstDepense.MoveFirst
While Not rstDepense.EOF
ColoneMois = Month("01/" & rstDepense![Mois] & "/1979") + 3
Ligne = Ligne - 7
For i = 1 To 7
Ligne = Ligne + 1
Set oCell = oFeuille.Cells(Ligne, ColoneMois)
Select Case i
Case 1
oCell.Value = rstDepense![MntEngageMois]
Case 2
oCell.Value = rstDepense![MntEngageCumul]
Case 3
oCell.Formulalocal = "=si(" & Chr(64 + 16) & Ligne - 2 & "=0; ;" & Chr(ColoneMois + 64) & Ligne - 1 & "/" & Chr(64 + 16) & Ligne - 2 & ")"
oCell.NumberFormat = "0%"
Case 4
oCell.Value = rstDepense![MntDepenseMois]
Case 5
oCell.Value = rstDepense![MntDepenseCumul]
Case 6
oCell.Formulalocal = "=si(" & Chr(64 + 16) & Ligne - 5 & "=0; ; " & Chr(ColoneMois + 64) & Ligne - 1 & "/" & Chr(64 + 16) & Ligne - 5 & ")"
oCell.NumberFormat = "0%"
Case 7
oCell.Formulalocal = "=si(" & Chr(64 + 16) & Ligne - 6 & "=0; ; " & Chr(64 + 16) & Ligne - 6 & "-" & Chr(ColoneMois + 64) & Ligne - 5 & ")"
End Select
oCell.Font.Size = 10
Next
rstDepense.MoveNext
Wend
rstDepenseCompte.MoveNext
Wend
LigneFinTab = Ligne
Next
oAppExcell.ActiveWindow.Zoom = 75
DoCmd.Close acForm, "frm_Patientez"
oAppExcell.Visible = True
'Debug.Print szChemin
'If (szChemin <> "") Then
'oClasseur.SaveAs szChemin
'End If
oAppExcell.Visible = True
End Sub |
Graphique excel
Répondre avec citation
Partager