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
| Option Explicit
'--- https://www.developpez.net/forums/d1726143/logiciels/microsoft-office/access/vba-access/optimisation-temps-traitement/
'--- demande référence Microsoft Excel x.xx Object Library
Sub Export_Xls(sRecordsource As String, sFullFileName As String) '--- Export via Excel en .xlsx ou .csv ou .txt
Dim oXls As Excel.Application
Dim oWb As Excel.Workbook
Dim oWsh As Excel.Worksheet
Dim rs As Recordset
Dim sFormat As String
Set oXls = CreateObject("Excel.Application")
oXls.Visible = True
Set oWb = oXls.Workbooks.Add
Set oWsh = oWb.Worksheets(1) '--- première feuille
Set rs = CurrentDb.QueryDefs(sRecordsource).OpenRecordset
oWsh.Range("A3").CopyFromRecordset rs
'oWsh.Range("A1") = "Ligne 1" '--- à adapter
sFormat = Mid(sFullFileName, InStrRev(sFullFileName, "."))
Select Case sFormat
Case ".xlsx"
oWb.SaveAs sFullFileName
Case ".csv"
'--- ne conserve pas les lignes vides !
'--- délimiteur=; --- dates FR
'oWb.SaveAs FileName:=sFullFileName, FileFormat:=xlCSV, CreateBackup:=False
'--- délimiteur=, --- dates US
'oWb.SaveAs FileName:=sFullFileName, FileFormat:=xlCSVMSDOS, CreateBackup:=False
oWb.SaveAs FileName:=sFullFileName, FileFormat:=xlCSVUTF8, CreateBackup:=False
Case ".txt"
'--- ne conserve pas les lignes vides !
'--- délimiteur=tabulation --- dates US
'oWb.SaveAs FileName:=sFullFileName, FileFormat:=xlTextWindows, CreateBackup:=False
oWb.SaveAs FileName:=sFullFileName, FileFormat:=xlUnicodeText, CreateBackup:=False
Case Else
MsgBox "Extension non reconnue!", , "Annulé"
End Select
'oXls.Quit
rs.Close
Set rs = Nothing
Set oWsh = Nothing
Set oWb = Nothing
Set oXls = Nothing
End Sub |
Partager