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
| Function TransfertBulletinVersExcel()
'Déclaration
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Workbook
Dim xlBook As Excel.Workbook
Dim I As Long, J As Long
Dim t0 As Long, t1 As Long
Dim db As Database, rst As Recordset, rec As Recordset, fld As DAO.Field
Dim CheminBulletin As String 'Est le chemin du fichier Exemple
Dim CheminACreer As String 'Est le chemin du Nouveau fichier
Dim sSQL As String, sSQL0 As String
CheminACreer = CurrentProject.path & "\" & Year(Now) & Month(Now) & Day(Now) & ".xlsm"
t0 = Timer 'Définition de temps initial
' Ouverture de la base de données
Set db = CurrentDb
sSQL = "SELECT Rqt_Rang.Numéro_Elève, Rqt_Rang.Matricule, tbl_Elèves.Nom_Elève, tbl_Elèves.Prénom_Elève, tbl_Elèves.Chemin_Photo, Rqt_Rang.Nom_Classe, Rqt_Rang.N°Evaluation, Rqt_Rang.Moyenne, Rqt_Rang.Rang, Rqt_Rang.Appreciation " & _
"FROM Rqt_Rang INNER JOIN tbl_Elèves ON Rqt_Rang.Numéro_Elève = tbl_Elèves.Numéro_Elève " & _
"WHERE (((Rqt_Rang.Numéro_Elève)=[txtMatriculeExport]), ((Rqt_Rang.N°Evaluation)=[txtTrimestreExport])); "
sSQL0 = "SELECT Rqt_prébulletin.Numéro_Elève, Rqt_prébulletin.Numéro_Matière, Rqt_prébulletin.Coefficient, Rqt_prébulletin.MinDeNote, Rqt_prébulletin.Note, Rqt_prébulletin.MaxDeNote " & _
"FROM Rqt_prébulletin " & _
"WHERE (((Rqt_prébulletin.Numéro_Elève)=[txtMatriculeExport]), ((Rqt_prébulletin.N°Evaluation)=[txtTrimestreExport])); "
' Ouverture du Recordset
Set rst = db.OpenRecordset(sSQL, dbOpenSnapshot)
Set rec = CurrentDb.OpenRecordset("sSQL0", dbOpenSnapshot)
'Appel du fichier Excel :
Set xlApp = CreateObject("Excel.Application")
xlApp.visible = True
'Vérification si fichier existe
If Dir(CheminBulletin) <> "" Then
Set xlSheet = xlApp.Workbooks.Open(CheminBulletin)
'Appel de la feuille correspondante :
xlApp.Sheets("NomFeuil").Select
'Remplissage dans Excel (exemple à partir de la première requête), sur des cellules bien précises.
'Attention la cellule (5,2) correspond à la cellule B5 d'Excel.
'La fonction rst correspond à un enregistrement Recordset.
xlApp.Cells(5, 2) = rst![Nomduchamp]
xlApp.Cells(5, 4) = rst![Nomduchamp]
xlApp.Cells(5, 7) = rst![Nomduchamp]
'Appel à la deuxième requête
' les entetes
' .Fields(Index).Name renvoie le nom du champ
For J = 0 To rec.Fields.Count - 1
xlApp.Cells(2, J + 1) = rec.Fields(J).Name
' Nous appliquons des enrichissements de format aux cellules
With xlApp.Cells(2, J + 1)
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
End With
Next J
' recopie des données à partir de la ligne 3
I = 3
Do While Not rec.EOF
For J = 0 To rec.Fields.Count - 1
' .Fields(Index).Type renvoie le type du champ
' si c'est un Texte (dbText) nous insérons "'" pour
' qu'il soit reconnu par Excel comme du Texte
If rec.Fields(J).Type = dbText Then
xlApp.Cells(I, J + 1) = "'" & rec.Fields(J)
Else
xlApp.Cells(I, J + 1) = rec.Fields(J)
End If
Next J
I = I + 1
rec.MoveNext
Loop
Else
MsgBox "Le chemin du fichier est introuvable !", vbCritical + vbOKOnly, "Chemin Introuvable"
End If
' code de fermeture et libération des objets
xlBook.SaveAs CheminACreer
'xlBook.SaveAs "D:\Feuille.xlsx"
xlApp.Quit
rst.Close ' Fermeture de la Premiere requête
rec.Close ' Fermeture de la Deuxième requête
Set rec = Nothing
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
t1 = Timer
'Debug.Print I & " enregistrements", Format(t1 - t0, "0") & " secondes"
MsgBox "Vous avez copié " & I & " enregistrements en " & Format(t1 - t0, "0") & " secondes", vbInformation, "Fichier envoyé avec succès"
End Function |
Exporter deux requête Access en Excel
Répondre avec citation
Envoyé par kabamel
Partager