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
| Public Function fuExcel() As String
'Gestion des erreurs
On Error GoTo fuExcel_err
'Le bloc ici est la déclaration des variables nécessaires
Dim xl As Excel.Application
Dim wbk As Excel.Workbook
Dim db As DAO.Database: Set db = CurrentDb
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim strSQL As String, strFeuil As String, strDossier As String, strMois As String, strAn As String
Dim loColone As Long, i As Long
'Ici on va récupérer le mois et l'année, si l'utilisateur clique sur annuler on exit la fonction
strMois = InputBox("Inscrire le mois de 1 à 12", "Choix du mois")
strAn = InputBox("Inscrire l'année exemple : 2015", "Choix de l'année")
If strAn = "" Or strMois = "" Then
fuExcel = "La commande à été annulée"
MsgBox fuExcel
Set db = Nothing
Exit Function
End If
'Ici on lance la requête pour ouvrir un recordset
strSQL = "SELECT T_rens_candidats.Nom, T_rens_candidats.Prénom, T_rens_candidats.Catégorie, " _
& "T_rens_candidats.[Date de passage AEMI], T_rens_candidats.Résultats, T_rens_candidats.Militaire, " _
& "T_rens_candidats.Civil, T_rens_candidats.SYGICOP, T_rens_candidats.[Décision finale], " _
& "T_rens_candidats.[SYGICOP finale], T_rens_candidats.Armée FROM T_rens_candidats " _
& "WHERE Month([Date de passage AEMI]) = " & CLng(strMois) _
& " And Year([Date de passage AEMI]) = " & CLng(strAn) _
& " ORDER BY T_rens_candidats.[Date de passage AEMI];"
Set rst = db.OpenRecordset(strSQL)
'On instancie l'Excel
'Il faut avoir cocher dans Outils/Références Microsoft Excel XX.X Object Library
Set xl = New Excel.Application
'Ici c'est le nom de la feuille dans laquelle on va mettre les données
strFeuil = "ACTI MED"
'Ici on indique à quelle ligne commencé dans ton cas la ligne 2
i = 2
With xl
'Ici il faut indiquer le chemin complet de l'emplacement du fichier plus le nom complet du fichier
Set wbk = .Workbooks.Open("C:\Users\Portable\Documents\Template.xls")
With wbk.Sheets(strFeuil)
While Not rst.EOF
loColone = 1 'Première colone de ton fichier Excel
For Each fld In rst.Fields
If loColone < 3 Then 'La colone 3 doit être sauter donc 3 = 4 et ainsi de suite
.Cells(i, loColone) = fld.Value
Else
.Cells(i, loColone + 1) = fld.Value
End If
loColone = loColone + 1
Next
rst.MoveNext
i = i + 1
Wend
rst.Close
Set rst = Nothing
End With
End With
strDossier = InputBox("Inscrire le chemin complet ainsi que le nom du fichier pour enregistrer le fichier." & Chr(13) _
& "Exemple: C:\Users\Portable\Documents\Décembre.xls", "Inscription du fichier")
'Si l'utilisateur clique sur annuler on ne sauvegarde pas le fichier créé
If strDossier <> "" Then
xl.ActiveWorkbook.SaveAs strDossier
fuExcel = "Emplacement et nom du fichier: " & strDossier & Chr(13) & "Nombre de ligne(s): " & i - 2
Else
fuExcel = "Le fichier a été créé, mais n'a pas été sauvegardé!!!"
End If
fuExcel_Exit:
MsgBox fuExcel
xl.Visible = True
Set xl = Nothing
Set wbk = Nothing
Set db = Nothing
Exit Function
fuExcel_err:
'Selon l'erreur on met le message approprié
Select Case Err.Number
Case 13
fuExcel = "L'utilisateur a déconné et inscrit du texte au lieu du chiffre attendu!!!"
Resume fuExcel_Exit
Case 9
fuExcel = "La feuille demandé n'a pas été trouvé!!!"
Resume fuExcel_Exit
Case 1004
If i = 2 Then
fuExcel = "Le fichier de départ n'a pas été trouvé!!!"
Resume fuExcel_Exit
Else
fuExcel = "Ce répertoire n'existe pas!!!"
Resume fuExcel_Exit
End If
Case Else
fuExcel = Err.Description & " " & Err.Number
Resume fuExcel_Exit
End Select
End Function |
Exporter des données vers excel. Et critères de requêtes.
j'ai chercher un bon moment sur internet mais je ne trouve pas mon bonheur
Répondre avec citation
Partager