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
| Private Sub Commande1_Click()
Dim t_secteur As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim db As DAO.Database
Dim i As Integer
Dim s As String, NumChamp As Long, ligne As Long
Set db = CurrentDb
Set qdf = db.QueryDefs("REFERENTIEL_SECTEURS")
For i = 0 To qdf.Parameters.Count - 1
On Error Resume Next
qdf.Parameters(i).Value = Eval(qdf.Parameters(i).Name)
If Err.Number = 2482 Then ' Paramètre non évaluable
' Demande la saisie du paramètre dans une inputbox
qdf.Parameters(i).Value = InputBox(qdf.Parameters(i).Name)
End If
On Error GoTo 0
Next
Set t = qdf.OpenRecordset 'ouvre la requete
Do Until t.EOF
Set xlA = CreateObject("excel.application") 'lance Excel
xlA.Visible = True
xlA.Workbooks.Open ("D:\Mes documents\GLOBAL\Satisfaction client\Baromètre\Analyse\Reporting\test.xls") 'ouvre le fichier
Set xlW = xlA.ActiveWorkbook
Call Exportation("BASE_RETOURS", "D:\Mes documents\GLOBAL\Satisfaction client\Baromètre\Analyse\Reporting\test.xls", "test")
xlW.SaveAs "D:\Mes documents\GLOBAL\Satisfaction client\Baromètre\Analyse\Reporting\ ' t_secteur!SECTEUR'_OK.xls"
xlA.Quit
Set xlA = Nothing ' puis libère la référence.
t_secteur.MoveNext
Loop
End Sub
Sub Exportation(requete As String, fichier As String, onglet As String)
Dim t As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim db As DAO.Database
Dim i As Integer
Dim s As String, NumChamp As Long, ligne As Long
ligne = 1
Set db = CurrentDb
Set qdf = db.QueryDefs(requete)
For i = 0 To qdf.Parameters.Count - 1
On Error Resume Next
qdf.Parameters(i).Value = Eval(qdf.Parameters(i).Name)
If Err.Number = 2482 Then ' Paramètre non évaluable
' Demande la saisie du paramètre dans une inputbox
qdf.Parameters(i).Value = InputBox(qdf.Parameters(i).Name)
End If
On Error GoTo 0
Next
Set t = qdf.OpenRecordset 'ouvre la requete
Do Until t.EOF
If t!SECTEUR = "Aquitaine" Then
ligne = ligne + 1 'ligne suivante dans la feuille Excel
For NumChamp = 0 To 24 'pour chaque colonne de la requete
If IsNull(t(NumChamp)) Then s = "" Else s = t(NumChamp) 'recupération des données au format Texte
xlW.Sheets(onglet).Cells(ligne, NumChamp + 1) = s 'ecriture dans la cellule
Next NumChamp
End If
t.MoveNext 'enregistrement suivant
Loop
t.Close
Set t = Nothing
Set qdf = Nothing
Set db = Nothing
End Sub |
Partager