Exporter une table Access vers EXCEL

Option Compare Database
Option Explicit
'

Dim Xlapp As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
'

Public Sub ExporteVersExcel()

Dim Db As DAO.Database
Dim Rs As DAO.Recordset
Dim NomFeuille As String

    On Error GoTo Err_ExporteVersExcel
    
    Set Xlapp = New Excel.Application
    'Set Xlapp = GetObject(, "Excel.Application")
    'On Error GoTo oups:
    On Error GoTo 0
    Xlapp.Visible = True
    NomFeuille = "S07"
    'NomFeuille = "S" & DatePart("ww", Date)
    Set XlBook = Xlapp.Workbooks.Open("C:\Nvx.xls")
    
    If FeuilleExiste(NomFeuille, XlBook.Name) Then
        Set XlSheet = XlBook.Worksheets("S07")
        ' efface les données
        XlSheet.Cells.Clear
    Else
        ' Ajouter nouvelle feuille en dernière position
        Set XlSheet = XlBook.Worksheets.Add(, XlBook.Worksheets(XlBook.Worksheets.Count))
        XlSheet.Name = NomFeuille
    End If

    Set Db = CurrentDb
    ' Copie dans feuille (nouvelle ou effacée)
    'Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
    Set Rs = Db.OpenRecordset("Requête Liste Titre")
    XlSheet.Range("A1").CopyFromRecordset Rs
    Set XlSheet = Nothing
    ' remise au début car le 'CopyFromRecordset' ne le fait pas
    Rs.MoveFirst
    '??? une 2ième foiS ??? XlSheet.Range("A1").CopyFromRecordset Rs
    ' Ferme les Var
    
    'Rs.Close '(lancer d'un form déjà aménagé pour moi)
    Set Rs = Nothing
    'Db.Close '(lancer d'un form déjà aménagé pour moi)
    Set Db = Nothing
    
    Set XlSheet = Nothing
    ' Sauve le fichier
    XlBook.Save
    'XlBook.Close
    Set XlBook = Nothing
    Set Xlapp = Nothing

'lupin*****************
Exit_ExporteVersExcel:
    '...
    Exit Sub

Err_ExporteVersExcel:
    
    'Err 429 : Un serveur OLE Automation ne peut pas créer d'objet
    ' -> Excel n'est PAS encore ouvert.
    If Err = 429 Then
        Set Xlapp = CreateObject("Excel.Application")
        Resume Next
    End If
    
oups:
    MsgBox Err.Number & " - " & Err.Description
    Resume Exit_ExporteVersExcel
    
End Sub
'

Function FeuilleExiste(NomFeuille As String, Classeur As String) As Boolean

    Dim Feuille As Object
    
    FeuilleExiste = False
    For Each Feuille In Xlapp.Worksheets
        If (Feuille.Name = NomFeuille) Then
            FeuilleExiste = True
        End If
    Next Feuille

End Function
'

Sub ExportTblAccessInExcel()


Dim Db As DAO.Database
Dim Rs As DAO.Recordset
Dim Xlapp As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet



On Error GoTo errOuvrirExcel
Set Xlapp = GetObject(, "Excel.Application")

On Error GoTo oups:

Xlapp.Visible = True


Set XlBook = Xlapp.Workbooks.Open("C:\Documents and Settings\A4382\Bureau\stage\Nvx clients par BG 2006 S14.xls")
Set XlSheet = XlBook.Sheets("S0")

' efface les données
XlSheet.Cells.Clear

Set Db = CurrentDb

' Copie dans S0
Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
XlSheet.Range("A1").CopyFromRecordset Rs

Set XlSheet = Nothing

' Ajout de la feuille
Set XlSheet = XlBook.Worksheets.Add
XlSheet.Name = "S15"

' remise au début car le 'CopyFromRecordset' ne le fait pas
Rs.MoveFirst
XlSheet.Range("A1").CopyFromRecordset Rs


' Ferme les Var
Rs.Close: Set Rs = Nothing
Db.Close: Set Db = Nothing
Set XlSheet = Nothing

' Sauve le fichier
XlBook.Save
XlBook.Close
Set XlBook = Nothing
Set Xlapp = Nothing


Exit Sub
errOuvrirExcel:
    'Err 429 : Un serveur OLE Automation ne peut pas créer d'objet
    '    ->  Excel n'est PAS encore ouvert.
    If Err = 429 Then
        Set Xlapp = CreateObject("Excel.Application")
        Resume Next
    End If

oups:
    MsgBox Err.Number & " - " & Err.Description

End Sub