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
| Public Sub create_Excel_file()
On Error GoTo Err_create_Excel_file
'**** DECLARATION DES VARIABLES
Dim xlApp As Excel.Application
Dim xlWkb As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim rstData As DAO.Recordset ' recordset contenant les données à exporter
Dim strFile_name As String
Dim strFile_path As String
Dim intNb_Ligne_Max As Long ' Nombre de ligne maximum dans une feuille Excel
Dim intCpt As Integer
'**** INITIALISATION DES VARIABLES
intNb_Ligne_Max = 65534
'--- Détermination du nom du fichier
strFile_path = "Ton Chemin"
strFile_name = strFile_path & "Ton nom de fichier"
'**** CODE DE LA PROCEDURE/FONCTION --------------------------------
'--- Ouverture d'un nouveau fichier selon un modèle
Set xlApp = CreateObject("Excel.Application")
'--- Ouverture du fichier destination
Set xlWkb = xlApp.Workbooks.Add()
'--- Chargement des données à exorter dans le recordset
Set rstData = CurrentDb.OpenRecordset("SELECT item FROM " & _
"(SELECT auto, nom as item, 'NOM' FROM matable " & _
"UNION " & _
"SELECT auto, prénom as item, 'PRENOM' FROM matable " & _
"ORDER BY 1, 3);")
'--- Exportation des données
'--- Vérification des données à transférer
If rstData.EOF = False Then
rstData.MoveLast ' obligatoire pour avoir le nb de ligne (pb access)
If rstData.RecordCount > intNb_Ligne_Max Then
MsgBox "Votre sélection contient trop de ligne." & vbCrLf & _
"Le nombre de ligne maximum supporté est " & intNb_Ligne_Max & vbCrLf & _
"Modifiez les critères de votre requête avant de retenter une exportation", vbCritical
GoTo Exit_create_Excel_file
End If
rstData.MoveFirst ' obligatoire pour charger toutes les données dans excel
' et non juste les record suivant le record actif (pb access)
Else
MsgBox "Vous ne pouvez pas exporter une sélection vide." & vbCrLf & _
"Modifier les critères de votre requête avant de retenter une exportation", vbCritical
GoTo Exit_create_Excel_file
End If
'--- Exportation des données dans le fichier excel
Set xlSheet = xlWkb.Worksheets(0)
xlSheet.Activate
xlApp.Range("A1").CopyFromRecordset rstData
rstData.Close
'--- Sauvegarde du résultat
xlApp.DisplayAlerts = False ' évite les msg de warning si le fichier existe déjà
'--- Sauvegarde du fichier
xlWkb.SaveAs strFile_name
Exit_create_Excel_file:
xlApp.DisplayAlerts = True
xlApp.ScreenUpdating = True
xlApp.Quit
'**** LIBERATION DE LA MEMOIRE
Set xlSheet = Nothing
Set xlWkb = Nothing
Set xlApp = Nothing
Set rstData = Nothing
Exit Sub
'**** GESTION DES ERREURS
Err_create_Excel_file:
MsgBox Error$
Resume Exit_create_Excel_file
End Sub |
Partager