Importer une requete access sur excel

**jahgor** · 21/08/2007, 20h53

Bonjour à tous,

je suis actuellement en stage. J'ai crée un programme grâce aux différentes informations obtenues sur ce forum. Je vous remercie pour cela. Le programme fonctionne assez bien lorsqu'il s'agit d'importer des tables mais pour les requêtes, il y a un message d'erreur qui apparaît: "La méthode Open de l'Objet Recordset a échoué" lors de l'ouverture du Recordset.

Je ne sais quoi faire alors que je souhaiterais importer une Requête access sur excel dont le nomest "Global"
Aidez-moi, SVP. Je vous remercie d'avance.

Voilà, mon programmme:

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
Sub ImporterDonneesDeAccess()
Dim X As Integer, C As Integer
Dim cnt As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Rg As Range, Sh As Worksheet
Dim NbEnr As Long, CheminDb As String
Dim NomTable As String, NomFeuille As String
Dim Tblo As Variant, Requete As String
 
CheminDb = "I:\IMPORT DONNEE/BETA2.2.mdb"
NomTable = "Global"
Requete = " Select * From " & NomTable & " "
 
'la chaîne de connexion à une base de données access
cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & CheminDb & ";"
 
'Ouverture du recordset
Rst.Open Requete, cnt, adOpenStatic
 
'Si aucun enregistrement est trouvé lors de la requête
If Rst.RecordCount = 0 Then
    MsgBox "Aucun enregistrement trouvé." & vbCrLf & "Fin de l'opération.", vbInformation + vbOKOnly, "Annulation"
    'Ferme la connection et le recordset
    Rst.Close: cnt.Close
    'libère la mémoire vive occupéé par les objets
    Set Rst = Nothing: Set cnt = Nothing
    Set Rg = Nothing: Set Sh = Nothing
    Exit Sub
End If
 
    'Eviter le rafraîchissement de l'écran
    Application.ScreenUpdating = False
 
    'Supprime la feuille
    Application.DisplayAlerts = False
    Worksheets("MVTS CPT Global").Delete
    Application.DisplayAlerts = True
 
    'Conserve dans une variable le nom de la feuille active.
    NomFeuille = ThisWorkbook.ActiveSheet.Name
 
 
    'Ajoute la nouvelle feuille: MVTS CPT Global où seront acheminées les données
    Set Sh = ActiveWorkbook.Worksheets.Add
    ActiveSheet.Name = "MVTS CPT Global"
 
    'détermine la cellule supérieur gauche où
    'le recordset va être copié
    With Sh
        Set Rg = .Range("A1")
    End With
 
 
    'Si tu es intéressé de récupérer directement les noms
    'des champs de ton recordset, tu peux utiliser ce
    'qui suit :
 
 
    Do
        Rg.Offset(, C) = Rst.Fields(C).Name
        C = C + 1
        X = X + 1
    Loop Until X = Rst.Fields.Count
 
 
'Section copiant le recordset dans excel
'La procédur va pouvoir choisir selon la version
'd'excel d'installer laquelle des méthodes choisir.
 
 
'Un test sur la version excel en cours ...
If Val(Mid(Application.Version, 1, InStr(1, _
    Application.Version, ".") - 1)) > 8 Then
    'EXCEL 2000 or 2002: La méthode CopyFromRecordset
    Rg.Offset(1).CopyFromRecordset Rst
Else
 
 
'Détermine le nombre d'enregistrements
    'Le +1 c'est pour tenir compte du tableau qui est de
    'base 0 ... première cellule dans excel est cells(1,1)
    NbEnr = UBound(Tblo, 2) + 1
 
 
    'Transpose le tableau(tblo) pour que la première dimension
    'devienne les données et que sa présentation soit
    'conforme lorsqu'il sera copié dans Excel
    Rg.Offset(1).Resize(NbEnr, Rst.Fields.Count).Value = TransposeSpecial(Tblo)
End If
 
 
    'Redimensionnement des cellules.
    Rg.CurrentRegion.Columns.AutoFit
    Rg.CurrentRegion.Rows.AutoFit
 
 
    'Sélection de la feuille au départ de la procédure
    Worksheets(NomFeuille).Select
 
 
     ' Ferme la connection et le recordset
     Rst.Close: cnt.Close
 
 
     'Libère la mémoire vive occupée par les objets
     Set Rst = Nothing: Set cnt = Nothing
     Set Rg = Nothing: Set Sh = Nothing
End Sub
 
Function TransposeSpecial(ByRef Arr As Variant) As Variant
Dim A As Integer, B As Integer, Arr1() As Variant
Dim C As Integer, D As Integer
    A = UBound(Arr, 1): B = UBound(Arr, 2)
    ReDim Arr1(B, A)
    For C = 0 To A
        For D = 0 To B
            Arr1(D, C) = Arr(C, D)
       Next
    Next
    TransposeSpecial = (Arr1)
End Function

**Heureux-oli** · 21/08/2007, 22h05

Pour deux programmes Office, il est plus facile d'utiliser du DAO que de ADO.

Christophe Warin a fait un super tuto sur le DOA. http://warin.developpez.com/

Tu peux faire appel au DAO au départ d'Excel, et tu te retrouve alors dans un environnement un peu plus souple et puissant.

**jahgor** · 22/08/2007, 09h17

Salut,

merci pour ta réponse mais le problème ce que je ne suis pas un expert et j déjà eu du mal à faire ce programme. Existe -il une fonction qui permette de résoudre ce problème d'erreur sans pour autant modifier entièrement mon programme?

**Heureux-oli** · 22/08/2007, 10h31

C'est ton chemin qui n'est pas bon

\ et / ne font pas bon ménage.

**jahgor** · 22/08/2007, 17h02

J'ai modifié le chemin d'accès mais cela ne fonctionne pas.
Chemin d'accès:

Code :

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

CheminDb = "G:\IMPORT DONNEE\BETA2.2.mdb"

Que dois_je faire?

**jahgor** · 27/08/2007, 11h03

ça y est !!!!
je vous remercie tous pour votre aide
Le code final qui servira peut-être à d'autres est:

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
Sub ImporterDonneesDeAccess()
Dim X As Integer, c As Integer
'Dim cnt As New ADOD.Connection
'Dim Rst As New ADODB.Recordset
Dim cnt As DAO.Database
Dim Rst As DAO.Recordset
Dim query As DAO.QueryDef
Dim Rg As Range, Sh As Worksheet
Dim NbEnr As Long, CheminDb As String
Dim NomTable As String, NomFeuille As String
Dim Tblo As Variant, Requete As String
 
CheminDb = "G:\IMPORT DONNEE1\BETA2.2.mdb"
'NomTable = "DEFI"
'Requete = " Select * From " & NomTable & " "
 
'la chaîne de connexion à une base de données access
'cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & CheminDb & ";"
Set cnt = DBEngine.Workspaces(0).OpenDatabase(CheminDb)
 
'Ouverture du recordset
'Rst.Open Requete, cnt, adOpenStatic
Set query = cnt.QueryDefs("Global")
Set Rst = query.OpenRecordset
 
'Si aucun enregistrement est trouvé lors de la requête
If Rst.RecordCount = 0 Then
    MsgBox "Aucun enregistrement trouvé." & vbCrLf & "Fin de l'opération.", vbInformation + vbOKOnly, "Annulation"
    'Ferme la connection et le recordset
    Rst.Close: cnt.Close
    'libère la mémoire vive occupéé par les objets
    Set Rst = Nothing: Set cnt = Nothing
    Set Rg = Nothing: Set Sh = Nothing
    Exit Sub
End If
 
    'Eviter le rafraîchissement de l'écran
    Application.ScreenUpdating = False
 
    'Supprime la feuille
    Application.DisplayAlerts = False
    Worksheets("MVTS CPT Global").Delete
    Application.DisplayAlerts = True
 
    'Conserve dans une variable le nom de la feuille active.
    NomFeuille = ThisWorkbook.ActiveSheet.Name
 
 
    'Ajoute la nouvelle feuille: MVTS CPT Global où seront acheminées les données
    Set Sh = ActiveWorkbook.Worksheets.Add
    ActiveSheet.Name = "MVTS CPT Global"
    Sheets("MVTS CPT Global").Move after:=Sheets("EXECUTION")
 
 
    'détermine la cellule supérieur gauche où
    'le recordset va être copié
    With Sh
        Set Rg = .Range("A1")
    End With
 
 
    'Si tu es intéressé de récupérer directement les noms
    'des champs de ton recordset, tu peux utiliser ce
    'qui suit :
    c = 0
 
    Do
        Rg.Offset(, c) = Rst.Fields(c).Name
        c = c + 1
        X = X + 1
    Loop Until X = Rst.Fields.Count
 
 
'Section copiant le recordset dans excel
'La procédur va pouvoir choisir selon la version
'd'excel d'installer laquelle des méthodes choisir.
 
 
'Un test sur la version excel en cours ...
If Val(Mid(Application.Version, 1, InStr(1, _
    Application.Version, ".") - 1)) > 8 Then
    'EXCEL 2000 or 2002: La méthode CopyFromRecordset
    Rg.Offset(1).CopyFromRecordset Rst
Else
 
 
'Détermine le nombre d'enregistrements
    'Le +1 c'est pour tenir compte du tableau qui est de
    'base 0 ... première cellule dans excel est cells(1,1)
    NbEnr = UBound(Tblo, 2) + 1
 
 
    'Transpose le tableau(tblo) pour que la première dimension
    'devienne les données et que sa présentation soit
    'conforme lorsqu'il sera copié dans Excel
    Rg.Offset(1).Resize(NbEnr, Rst.Fields.Count).Value = TransposeSpecial(Tblo)
End If
 
 
    'Redimensionnement des cellules.
    Rg.CurrentRegion.Columns.AutoFit
    Rg.CurrentRegion.Rows.AutoFit
 
 
    'Sélection de la feuille au départ de la procédure
    Worksheets(NomFeuille).Select
 
 
     ' Ferme la connection et le recordset
     Rst.Close: cnt.Close
 
 
     'Libère la mémoire vive occupée par les objets
     Set Rst = Nothing: Set cnt = Nothing
     Set Rg = Nothing: Set Sh = Nothing
 Call fillForm
End Sub
'------------------------------------------
 
 
'Fonction requise par la procédure pour les
'versions antérieures à excel 200
 
 
'------------------------------------------
Function TransposeSpecial(ByRef Arr As Variant) As Variant
Dim A As Integer, B As Integer, Arr1() As Variant
Dim c As Integer, D As Integer
   'A = UBound(Arr, 1): B = UBound(Arr, 2)
    ReDim Arr1(B, A)
    For c = 0 To A
        For D = 0 To B
            Arr1(D, c) = Arr(c, D)
       Next
   Next
    TransposeSpecial = (Arr1)
 
End Function

Importer une requete access sur excel

VBA Access

Discussions similaires

Partager

Partager