Discussion :

[Vetter]

Bonjour à tous,

J'effectue un balayage d'un fichier EXCEL via le VBA d'ACCESS
Lorsque il y a une correspondance entre deux valeurs j'attribue une valeur sur la même ligne.
Ce balayage est rendu possible grâce au code ci-dessous.
Le problème que je rencontre concerne l’exécution de mon code qui est beaucoup trop long

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
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

Quelqu'un pourrait-il donc m'aider pour réduire ce temps ?

Merci d'avance de votre aide

[carden752]

Bonjour,

Plusieurs remarques
Déjà, nous ne savons pas quelle partie de ton code est à optimiser?

Ensuite, tu demandes l'appel à plusieurs reprises d'une même requête qui a 2 filtres le nom de l'employé et la date. Peut être serait-il mieux de la faire qu'une fois et stocker son résultat dans un tableau ou une feuille que tu supprimes à la fin.

Enfin pour améliorer ce code, je pense que cela rentre dans de l'optimisation de base de données donc à voir sur le forum de base de données pour optimiser tes requêtes mais sans le modele de données, je ne sais pas si c'est possible. Comme cela, je ne vois pas de grandes améliorations dessus, peut-être créer une vue pour réduire le nombre d'employé au départ si tu n'en utilises que certains.

Je pense que chacune des requêtes est courte mais c'est la répétition de celles-ci qui augmente considérablement le temps de traitement. Peut-être le stockage de toutes les valeurs permettrait de modifier cette donnée, à tester.

[loufab]

Bonjour,

Partie Excel :

Tu peux peut-être utiliser une fonction de recherche au lieu du parcours cellules à cellules.

Concernant Excel regarde la bible présente dans les tutos.
http://bidou.developpez.com/article/VBA/
à partir de la page 180.

Partie ACCESS :

Apparement tu fais des opérations d'agrégation pour savoir si un tuple existe. Pourquoi ne pas faire un findfirst tout simplement ? Avec un recordset global tu devrais gagner du temps machine.

Code :

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

1
2
3
4
5
6
7
8
dim db as dao.database
dim grst as dao.recordset
 
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
set db = currentdb
set grst = db.openrecordset(""SELECT Employe, DateJ, Machine FROM T_Planning;",dbopensnapshot)
...

Dans Trouv et TrouvR.

Code :

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

1
2
3
Function trouv(nomEmp As String, dat As Date) As boolean       grst.findfirst "Employe=""" & nomemp & """ AND DateJ=" & Dat 
trouv = not rst.nomatch    
End Function

à étendre à GetRepos et les autres.
Idem pour vide() !
Un FindFirst sur Employé dans le gRst t'indiquera si oui ou non il y en a un.
Le Count() doit être réservé à renvoyer un nombre d'occurence pas à vérifier l'existence d'un tuple.

Cordialement,