Function ExportExcel()

DoCmd.OutputTo acOutputForm, _
                "Clients", _
                acSpreadsheetTypeExcel9, _
                "Clients.xls", _
                True
End Function

Function TransfertExportExcel()

DoCmd.TransferSpreadsheet acExport, _
                    acSpreadsheetTypeExcel9, _
                    "Clients", _
                    "Clients.xls", _
                    True
End Function

Function TransfertExcelAutomation()

    Dim xlApp As Excel.Application
    Dim xlSheet As Excel.Worksheet
    Dim xlBook As Excel.Workbook
    Dim I As Long, J As Long
    Dim t0 As Long, t1 As Long
    
    t0 = Timer
    Dim rec As Recordset
    
    Set rec = CurrentDb.OpenRecordset("Clients", dbOpenSnapshot)
    
    'Initialisations
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
   
    'Ajouter une feuille de calcul
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Name = "Tutoriel"
   
    ' le titre
    '  écriture dans la cellule de ligne 1 et de colonne 1
    xlSheet.Cells(1, 1) = "Export d'une table Access"
   
    
    ' les entetes
    '  .Fields(Index).Name renvoie le nom du champ
    For J = 0 To rec.Fields.Count - 1
        xlSheet.Cells(2, J + 1) = rec.Fields(J).Name
        ' Nous appliquons des enrichissements de format aux cellules
        With xlSheet.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
                xlSheet.Cells(I, J + 1) = "'" & rec.Fields(J)
            Else
                xlSheet.Cells(I, J + 1) = rec.Fields(J)
            End If
        Next J
        I = I + 1
        rec.MoveNext
    Loop
   
    ' code de fermeture et libération des objets
    xlBook.SaveAs "D:\Temp\Feuille.xls"
    xlApp.Quit
    rec.Close
    Set rec = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing

    t1 = Timer
    Debug.Print I & " enregistrements", Format(t1 - t0, "0") & " secondes"

End Function

TransfertExcelAutomation
 94 enregistrements          1 secondes

SELECT Employés.[N° employé], Employés.Nom, Employés.Prénom, 
   Commandes.[N° commande], Commandes.[Code client], Commandes.[Date commande], [Détails commandes].[Prix unitaire], 
   [Détails commandes].Quantité
FROM (Employés INNER JOIN Commandes ON Employés.[N° employé] = Commandes.[N° employé]) 
   INNER JOIN [Détails commandes] ON Commandes.[N° commande] = [Détails commandes].[N° commande];

Public cnx As ADODB.Connection

Sub auto_open()
    ' La sub auto_open possède la propriété d'être automatiquement
	'  exécutée à l'ouverture du classeur Excel
	'  à l'identique : auto_close est exécutée sur la fermeture   
    Dim strPath As String
    
    ' Seule contrainte une cellule nommée strPath
    '  doit être présente dans le classeur et
    '  renvoyer sur le chemin de l'appli
    '  en l'occurence Comptoir.mdb
    Application.Goto Reference:="StrPath"
    
    strPath = ActiveCell
    
    ' Nous testons si le fichier est accessible
    If Len(Dir(strPath)) > 0 Then
        ' Déclaration de la variable de connexion
        Set cnx = New ADODB.Connection
        
        ' Connexion à la base
        ConnectDB cnx, strPath
    Else
        MsgBox "La base n'a pas pu être trouvée" & vbCrLf & _
                strPath & vbCrLf & _
                "n'est pas un chemin valide.", vbCritical + vbOKOnly
    End If
    
End Sub

Sub ConnectDB(ByRef cnx As ADODB.Connection, ByVal strPath As String)
    
    'Définition du pilote de connexion
    cnx.Provider = "Microsoft.Jet.Oledb.4.0"
    'Définition de la chaîne de connexion
    cnx.ConnectionString = strPath
    'Ouverture de la base de données
    cnx.Open
    
End Sub

Public Function xRetrieve(Optional ByVal NomEmployé As String = vbNullString, _
                          Optional ByVal Mois As Date = 0, _
                          Optional ByVal Quarterly As Boolean = False)
' Chaine de caractère : nom de l'employé ou cellule qui contient cette information
' Date : date qui va indiquer le mois de la requête  ou cellule qui contient cette information
' Booléen : Si vrai => informations trimestrielles, Si faux => informations mensuelles

    
    Dim rec As New ADODB.Recordset
    Dim strSQL As String
    
    
    'Redaction du SQL
    strSQL = "SELECT Sum([Prix unitaire] * [Quantité]) AS MONTANT " & _
             "FROM [qryXLSlookup] WHERE 1=1"
    
    ' rappelons que les chaines de caractères en SQL sont à entourer de ''
    ' /!\ toute insertion de chaine dans un SQL comporte un danger pour les données
    '     nous pourrions fort bien ici contrôler le contenu pour neutraliser la
    '     la présence de mots clés placés involontairement ou par malveillance
    If Len(NomEmployé) > 0 Then
        strSQL = strSQL & " And ([Nom] = '" & NomEmployé & "')"
    End If
    
    ' rappelons que les dates en SQL sont à mettre au format US
    If Mois > 0 Then
        strSQL = strSQL & " And ([Date Commande] Between #" & _
                Format(MoisInf(Mois, Quarterly), "mm/dd/yyyy") & "# And #" & _
                Format(MoisSup(Mois, Quarterly), "mm/dd/yyyy") & "#)"
    End If
    
    Dim rst As New ADODB.Recordset
    
    rst.Open strSQL, cnx
    
    On Error GoTo errH01
    rst.MoveFirst
    
    xRetrieve = CDbl(rst("MONTANT"))
    
    rst.Close
    Set rst = Nothing
    Exit Function
    
errH01:
    ' Nous sommes dans un tableur excel,
    '  nous ne cherchons pas à analyser les éventuelles erreurs
    '  nous rendons la main au tableur.
    Err.Clear
    xRetrieve = 0
    rst.Close
    Set rst = Nothing
    
    
End Function


Function MoisInf(ByVal dat As Date, ByVal blnQter As Boolean) As Date
' Fonction qui permet d'obtenir la première date du mois / trimestre

If Not blnQter Then
    MoisInf = CDate("01/" & Month(dat) & "/" & Year(dat))
Else
    MoisInf = CDate("01/" & ((Month(dat) \ 4) * 3) + 1 & "/" & Year(dat))
End If

End Function

Function MoisSup(ByVal dat As Date, ByVal blnQter As Boolean) As Date
' Fonction qui permet d'obtenir la dernière date du mois / trimestre

If Not blnQter Then
    MoisSup = DateAdd("m", 1, MoisInf(dat, blnQter)) - 1
Else
    MoisSup = DateAdd("m", 3, MoisInf(dat, blnQter)) - 1
End If
End Function