Discussion :

[blindacrobate]

Bonjour à tous,

je suis autodidacte et plutôt bricoleur en VBA

Je tourne en rond depuis deux jours sans trouver la solution à mon problème.

J'ai un fichier excel .xlm qui interroge une database access .mdb (version accdb aussi disponible).

voici les références dans mon VBA



Je l'interroge pour remplir mes listes déroulantes d'excel, jusque là sans aucun soucis.

A noter que je mets à Zéro systématiquement mon recordset après avoir rempli chaque liste déroulante (il y en a 14) et le ferme ainsi que ma connexion quand toutes mes listes déroulantes ont été remplies

C'est ensuite lorsque que j'utilise mon fichier excel pour rapatrier des données sélectionnées selon plusieurs critères que j'ai des soucis.

Il s'agit de requêtes imbriquées sur plusieurs niveaux

J'ai testé mes requêtes issues de mon formulaire excel dans Access et elles fonctionnent impeccablement.

Dans une version antérieure dudit fichier excel, avant office 365, dans mes requêtes sql pour interroger Access, je devais, pour je ne sais quelle raison, remplacer les guillemets chr(34) par un apostrophe chr(39) et l'étoile "*" chr(42) par un "%" chr(37)

c'était bizarre mais cela avait le mérite de fonctionner.

A l'heure de passer à Excel 365 j'ai fait migrer mon fichier .xls vers un .xlm et en ai profité pour le modifier notamment pour la chaîne de connexion

mes variables sont définies comme suit :

Code :

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

1
2
3
4
Public ADOConnection As ADODB.Connection
Public adorecordset As ADODB.Recordset
Public Str As String
Public MonjeuEnregdécroissant As String

ma chaîne de connexion est la suivante :

Code :

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

1
2
3
4
Public Const ConnectString As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data source=C:\Users\3804\Desktop\PLANO-EVO\plansdata.mdb;persist security info = false"
 
"pour info :
'ancienne ConnectString = "Provider=Microsoft.jet.oledb.4.0;Data source=" & scanpath & "\planotheque\plans\database\plansdata.mdb;persist security info = false"

le contenu de mon SELECT contenu dans MonjeuEnregdécroissant est :

Code :

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

1
2
 
SELECT DISTINCT plans.*, archivesTYPEdoc.typededocument, archivesTYPEdoc.Date, archivesSCANS.lien, archivesSCANS.taillefichier, archivesSCANS.lienOK FROM ([atlas des routes de D142] INNER JOIN ((plans INNER JOIN archivesTYPEdoc ON plans.[code plan] = archivesTYPEdoc.[code plan]) INNER JOIN [communes des plans] ON plans.[code plan] = [communes des plans].[code plan]) ON [atlas des routes de D142].[code atlas] = [communes des plans].[code atlas]) LEFT JOIN archivesSCANS ON plans.[code plan] = archivesSCANS.[code plan] WHERE (([plans].[P t])=-1) And (([atlas des routes de D142].[n° route])="A15") And (([atlas des routes de D142].[code atlas])=385) And ((archivesTYPEdoc.typeDOCdfltSELECTED)=True) And (([plans].[Intitulé]) Not Like "*nouveau plan*") ORDER BY plans.sortkey1 DESC , plans.[n° plan compilé] DESC , plans.sortkey2 DESC , plans.[ancien n° plan compilé] DESC

et il fonctionne parfaitement dans Access

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
Sub extraction()
'On Error GoTo errorHandler
Dim PREVIOUScodeARCH As Long
 
effacementliste
nbenreg = 0
If NbrArg = 0 And NbrARG2 = 0 Then
   MsgBox "aucun critère n'a été introduit ==> pas de recherche possible !"
   Worksheets("résultats").boutonimprimer.Enabled = False
   Exit Sub
End If
 
Worksheets("résultats").sqlVERIF = MonjeuEnregdécroissant
 
Application.ScreenUpdating = False
 
Set ADOConnection = New ADODB.Connection
ADOConnection.Open ConnectString
 
'La requete MySQL dans ta table
Str = MonjeuEnregdécroissant
 
k = 3
Set adorecordset = New ADODB.Recordset
adorecordset.Open Str, ADOConnection, adOpenKeyset, adLockOptimistic, adCmdText
 
'si le nombre d'enregistrement sélectionné est supérieur à 1000 alors on demande de rendre la recherche plus restritive
If adorecordset.RecordCount > 1000 Then
   MsgBox "vos critères ne sont pas assez rectrictif, " & adorecordset.RecordCount & " enregistrements ont été sélectionnés !" & Chr(13) & Chr(13) & "Veuillez affiner votre recherche SVP !"
 
   Worksheets("résultats").boutonimprimer.Enabled = False
   'Application.ScreenUpdating = True
   GoTo EXTRACTIONfin
End If
'On se place sur le 1er enegistrement
 
If adorecordset.RecordCount = 0 Then 'pas d'enregistrement trouvé
   MsgBox "aucun enregistrement sélectionné !"
   Worksheets("résultats").boutonimprimer.Enabled = False
   GoTo EXTRACTIONfin
Else ' il y a entre 1 et 1000 enregistrements trouvés
   adorecordset.MoveFirst
 
'Début de la boucle pour extraire les résultats
   Do While Not adorecordset.EOF()
   If adorecordset![code plan] = PREVIOUScodeARCH Then GoTo extractionLIEN
   Select Case adorecordset![typededocument]
   Case 1
   Cells(k, 1) = "Autre"
   Case 2
   Cells(k, 1) = "Brochure technique"
   Case 3
   Cells(k, 1) = "Cahier spécial des charges"
   Case 4
   Cells(k, 1) = "Convention"
   Case 5
   Cells(k, 1) = "Croquis A4"
   Case 6
   Cells(k, 1) = "D.I.U."
   Case 7
   Cells(k, 1) = "Métré"
   Case 8
   Cells(k, 1) = "Note de calcul"
   Case 9
   Cells(k, 1) = "Photo"
   Case 10
   Cells(k, 1) = "Plan"
   Case 11
   Cells(k, 1) = "Rapport d'inspection"
   Case 12
   Cells(k, 1) = "Remise de prix"
   Case 13
   Cells(k, 1) = "Epreuve de pont"
   Case 14
   Cells(k, 1) = "Bordereau des aciers"
   Case 15
   Cells(k, 1) = "Dossier"
   Case 30
   Cells(k, 1) = "reprises/remises de voiries"
   End Select
   If adorecordset![présent dans clabo ?] = 0 Then
      Cells(k, 2) = "à vérifier"
   End If
   If adorecordset![présent dans clabo ?] = 1 Then
      Cells(k, 2) = "oui"
      Cells(k, 2).Font.ColorIndex = 2
      Cells(k, 2).Interior.ColorIndex = 50
   End If
   If adorecordset![présent dans clabo ?] = 2 Then
      Cells(k, 2) = "manquant"
      Cells(k, 2).Font.ColorIndex = 2
      Cells(k, 2).Interior.ColorIndex = 3
   End If
   If adorecordset![présent dans clabo ?] = 3 Then
      Cells(k, 2).Font.ColorIndex = 2
      Cells(k, 2).Interior.ColorIndex = 45
      Cells(k, 2) = "détruit"
   End If
   If adorecordset![présent dans clabo ?] = 4 Then
      Cells(k, 2).Font.ColorIndex = 2
      Cells(k, 2).Interior.ColorIndex = 37
      Cells(k, 2) = "virtuel"
   End If
   Cells(k, 3) = adorecordset![Date]
   Cells(k, 4) = adorecordset![n° plan compilé]
   Cells(k, 5) = adorecordset![ancien n° plan compilé]
   Cells(k, 6) = adorecordset![Intitulé]
   'Cells(k, 7) = adorecordset![classement]
   Cells(k, 8) = adorecordset![caractéristiques]
   Cells(k, 9) = adorecordset![commentaires]
 
   Dim hyperlien As String
 
extractionLIEN:
   If adorecordset![lien] <> "" Then
      hyperlien = CStr(adorecordset![lien])
      hyperlien = scanpath & hyperlien
      With Worksheets(1)
        .Hyperlinks.Add Anchor:=.Cells(k, 10), _
        Address:=hyperlien, _
        ScreenTip:=hyperlien, _
        TextToDisplay:=hyperlien
      End With
   End If
   Cells(k, 11) = adorecordset![taillefichier]
If adorecordset![code plan] = PREVIOUScodeARCH Then GoTo FORnextARCH
 
   Select Case adorecordset![conformitéduplaninsitu]
   Case 0
   Cells(k, 12) = "ND"
   Case 1
   Cells(k, 12) = "à vérifier"
   Case 2
   Cells(k, 12) = "partielle"
   Case 3
   Cells(k, 12) = "totale"
   Case 4
   Cells(k, 12) = "non réalisé"
   Case 5
   Cells(k, 12) = "vérification inutile"
   End Select
 
FORnextARCH:
   PREVIOUScodeARCH = adorecordset![code plan]
   adorecordset.MoveNext
   k = k + 1
   Loop
Worksheets("résultats").boutonimprimer.Enabled = True
Worksheets("résultats").boutonexporter.Enabled = True
Worksheets("résultats").boutonenvoyerparmail.Enabled = False
'Fin de la boucle
End If
nbenreg = Val(adorecordset.RecordCount)
 
MsgBox adorecordset.RecordCount & " enregistrement(s) trouvé(s)."
 
'Fin de la connexion
 
EXTRACTIONfin:
Set ADOConnection = Nothing
Set adorecordset = Nothing
ADOConnection.Close
Application.ScreenUpdating = True
 
Exit Sub
 
errorHandler:
    'indique le numéro et la description de l'erreur survenue
    MsgBox Err.Number & vbLf & Err.Description & Chr(13) & Chr(13) & "Veuillez noter le message d'erreur et le communiquer à votre administrateur - merci."
 
End Sub

Au final j'obtiens ce message d'erreur toujours au même endroit



Je ne parviens pas à déterminer si c'est ma connexion qui pose problème mais dans ce cas elle serait aussi problématique lorsque je remplis mes listes déroulantes lors de l'ouverture de mon fichier excel ou plus que probablement mon instruction SQL imbriquée ….


Help, Help, Help