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
| Option Compare Text
Public Function addToExcel(DateDeb As Date, path As String) As Integer
' Fonction qui parcours le fichier EXCEL est ajoute '8' en fonction du poste et de la date
Dim xlapp, owk As Object
Dim i, j As Integer
Dim variable As String
Set xlapp = CreateObject("Excel.Application")
rep = 0
Set owk = xlapp.Workbooks.Open(path)
xlapp.Calculation = -4135
xlapp.ScreenUpdating = False
xlapp.Visible = False
If (vide > 0) Then
For i = 0 To 6
With owk.Sheets(i + 3)
For j = 2 To 225
variable = .Cells(j, 2)
If trouv(variable, DateAdd("d", i, DateDeb)) > 0 Then
Select Case getLigne(variable, DateAdd("d", i, DateDeb))
Case "REMY 500"
.Cells(j, 3) = "8"
rep = rep + 1
Case "AMPACK"
.Cells(j, 4) = "8"
rep = rep + 1
Case "LIEDER"
.Cells(j, 5) = "8"
rep = rep + 1
Case "GUALAPACK"
.Cells(j, 6) = "8"
rep = rep + 1
Case "REMY KG"
.Cells(j, 7) = "8"
rep = rep + 1
Case "ERCA1"
.Cells(j, 8) = "8"
rep = rep + 1
Case "ERCA2"
.Cells(j, 9) = "8"
rep = rep + 1
Case "ERCA4"
.Cells(j, 10) = "8"
rep = rep + 1
Case "ERCA5"
.Cells(j, 11) = "8"
rep = rep + 1
Case "SEAUX"
.Cells(j, 12) = "8"
rep = rep + 1
Case "CARTON"
.Cells(j, 15) = "8"
rep = rep + 1
Case "EMBALLAGE"
.Cells(j, 16) = "8"
rep = rep + 1
Case "PROPRETE NET"
.Cells(j, 17) = "8"
rep = rep + 1
Case "PROPRETE RECY"
.Cells(j, 18) = "8"
rep = rep + 1
Case "CONTAINERS AT"
.Cells(j, 19) = "8"
rep = rep + 1
Case "CONTAINERS CHOCO"
.Cells(j, 22) = "8"
rep = rep + 1
End Select
ElseIf trouvR(variable, DateAdd("d", i, DateDeb)) > 0 Then
.Cells(j, 31) = getRepos(variable, DateAdd("d", i, DateDeb))
rep = rep + 1
End If
Next j
End With
Next i
End If
xlapp.ScreenUpdating = True
xlapp.Calculation = -4105
xlapp.Visible = True
Set xlapp = Nothing
addToExcel = rep
End Function
Function trouv(nomEmp As String, dat As Date) As Integer
' Retourne un entier correspondant à la présence de l'employé dans la table T_Planning
Dim db As DAO.Database
Dim req As DAO.Recordset
Dim sql As String
Set db = CurrentDb()
sql = "SELECT COUNT(Employe) FROM T_Planning HAVING Employe='" &
nomEmp & "' AND DateJ Like '" & dat & "'"
Set req = db.OpenRecordset(sql)
trouv = req.Fields(0)
End Function
Function trouvR(nomEmp As String, dat As Date) As Integer
' Retourne un entier correspondant à la présence du repos dans la table T_PlanningRepos
Dim db As DAO.Database
Dim req As DAO.Recordset
Dim sql As String
Set db = CurrentDb()
sql = "SELECT COUNT(T_PlanningRepos.idEmploye)
FROM T_PlanningRepos INNER JOIN T_Employe ON
(T_PlanningRepos.idEmploye=T_Employe.idEmploye) WHERE
(T_Employe.NomEmploye+' '+T_Employe.PrenomEmploye)='" &
nomEmp & "' AND T_PlanningRepos.DateJ Like '" & dat & "'"
Set req = db.OpenRecordset(sql)
trouvR = req.Fields(0)
End Function
Function getLigne(nomEmp As String, dat As Date) As String
' Retourne le poste coorespondant à l'employé et à la date
Dim db As DAO.Database
Dim req As DAO.Recordset
Dim sql As String
Set db = CurrentDb()
sql = "SELECT Machine FROM T_Planning WHERE Employe='" & nomEmp & "'
AND DateJ LIKE '" & dat & "'"
Set req = db.OpenRecordset(sql)
If (req.Fields(0) = "ANNEXES") Then
getLigne = getPosteAnnexes(nomEmp, dat)
Else
getLigne = req.Fields(0)
End If
End Function
Function getRepos(nomEmp As String, dat As Date) As String
' Retourne le repos coorespondant à l'employé et à la date
Dim db As DAO.Database
Dim req As DAO.Recordset
Dim sql As String
Set db = CurrentDb()
sql = "SELECT T_PlanningRepos.Repos FROM T_PlanningRepos INNER JOIN
T_Employe ON (T_PlanningRepos.idEmploye=T_Employe.idEmploye) WHERE
(T_Employe.NomEmploye+' '+T_Employe.PrenomEmploye)='" & nomEmp & "'
AND T_PlanningRepos.DateJ LIKE '" & dat & "'"
Set req = db.OpenRecordset(sql)
getRepos = req.Fields(0)
End Function
Function getPosteAnnexes(nomEmp As String, dat As Date) As String
' Retourne le poste annexes coorespondant à l'employé et à la date
Dim db As DAO.Database
Dim req As DAO.Recordset
Dim sql As String
Set db = CurrentDb()
sql = "SELECT Poste FROM T_Planning WHERE Employe='" & nomEmp & "'
AND DateJ LIKE '" & dat & "' AND Machine='ANNEXES'"
Set req = db.OpenRecordset(sql)
getPosteAnnexes = req.Fields(0)
End Function
Function vide() As Integer
' Retourne un entier correspondant à la présence ou non de données dans la table T_Planning
Dim db As DAO.Database
Dim req As DAO.Recordset
Dim sql As String
Set db = CurrentDb()
sql = "SELECT COUNT(Employe) FROM T_Planning"
Set req = db.OpenRecordset(sql)
vide = req.Fields(0)
End Function |
[ACCESS-2003] Comment optimiser mon code pour réduire tps d'execution ?
Répondre avec citation
Partager