Exporter une table Access vers EXCEL

PAULOM -  
Bonjour à tous,
J'aimerais exporter une table Access vers une feuille Excel deja existante.
Car à chque fois que je lance le module ça me met cette erreur:

Erreur d'execution '1004':
Impossible de renommer une feuille comme une autre feuille, une bibliotheque d'objets référencée ou un classeur référencée par Visual Basic

Voici mon code: 
Option Compare Database
 
Global Const RepertoireTableauBord As String = "C:\Documents and Settings\A4382\Bureau\stage\"
Global Const Titre As String = "Suivi Conquête "
Dim erreur_traitement As Boolean
 
 
Function ExportExcel()

Dim db As DAO.Database
Dim IndicateursSemaine As DAO.Recordset
Dim Total As Integer
Dim xlApp As Object
 
Set db = CurrentDb

'Lancement d'EXCEL
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
 
'Affectation du nom du classeur de suivi
TableauBordSuivi = "Nvx clients par BG 2006 S14.xls"

'Test d'existence du classeur
Set fs = CreateObject("Scripting.FileSystemObject")
    
    If fs.FileExists(RepertoireTableauBord & TableauBordSuivi) = False Then
        erreur = MsgBox("Le fichier " & RepertoireTableauBord & TableauBordSuivi & " n'existe pas !", 16, Titre)
        Exit Function
        Else
        xlApp.Workbooks.Open Filename:=RepertoireTableauBord & TableauBordSuivi
    End If

'Extraction des rubriques de la table Tmp_Indicateurs pour la semaine à traiter
Set IndicateursSemaine = db.OpenRecordset("select Semaine, BG, Nb_Mineur, Nb_Part, Nb_Pro, Nb_SCI, Nb_Asso, Total_BG from T31_Cumul_Nvx_clients_par_BG order by BG")
' MsgBox Nz(ZoneDeTexte) + 1
Numsemaine = "S0"

 


'Création feuille de la semaine, sauf si déjà existante.
IndExiste = 0
For Each feuille In xlApp.ActiveWorkbook.Sheets
    If feuille.Name = Numsemaine Then
    IndExiste = 1
    End If
Next feuille

If IndExiste = 0 Then
    xlApp.ActiveWorkbook.Sheets(1).Copy After:=xlApp.ActiveWorkbook.Sheets(IndicateursSemaine![Semaine] + 1)
   
    'xlApp.ActiveWorkbook.Sheets.Add
End If

xlApp.ActiveWorkbook.ActiveSheet.Name = Numsemaine

    xlApp.ActiveWorkbook.Close SaveChanges:=True
    xlApp.Application.WindowState = xlMinimized
    xlApp.Quit
    Set xlApp = Nothing
'Mise à jour des zones concernées

    DoCmd.TransferSpreadsheet acExport, 8, "T31_Cumul_Nvx_clients_par_BG", RepertoireTableauBord & TableauBordSuivi, True, Numsemaine & "!A:G"

'Fermeture avec enregistrement du tableau de bord, et libération des ressources
'xlApp.ActiveWorkbook.Close SaveChanges:=True

    'Enregistrement du tableau de bord Agent
  '  xlApp.ActiveWorkbook.Save
   ' xlApp.Application.WindowState = xlMinimized
    
Sheets("S0").Select
    Selection.Copy
    Sheets("S15").Select
    Range("A1").Select
    ActiveSheet.Paste
IndicateursSemaine.Close


'xlApp.Quit
'Set xlApp = Nothing]
Set IndicateursSemaine = Nothing
Set db = Nothing
Exit Function




     
End Function


Merci beaucoup pour votre aide...

11 réponses

  1. Utilisateur anonyme
    Bonjour,

    ce pourrait être cette ligne !

    xlApp.ActiveWorkbook.Sheets(1).Copy After:=xlApp.ActiveWorkbook.Sheets(IndicateursSemaine![Semaine] + 1)

    Je crois comprendre ce que vous tenter de faire, si vous étiez
    sous VBA pas de problème, mais en VBS certaines options ne
    réponde pas toujours.

    si cette syntaxe ne fonctionne pas !
    xlApp.ActiveWorkbook.Sheets(1).Copy After:=Sheets(IndicateursSemaine![Semaine] + 1)

    alors contourné ce problème en placant une feuille masqué et

    xlApp.ActiveWorkbook.Sheets("Robot").Visible = True
    xlApp.ActiveWorkbook.Sheets("Robot").Select
    xlApp.ActiveWorkbook.Sheets(1).Copy Before:=Sheets("Robot")
    xlApp.ActiveWorkbook.Sheets("Robot").Visible = False

    autre suggestion, déclaré un objet BooK, exemple

    dim xlBK
    Set xlBK = xlApp.ActiveWorkBook

    Lupin
    2
    1. PAULOM
      Merci LUPIN je me suis servis de votre code pour faire fonctionner le mien.

      C'est vraiment gentil de votre part!
      0
      1. PAULOM
        Merci beaucoup pour votre aide lupin, je vous tiens au courant...
        0
        1. Utilisateur anonyme
          Bonjour,

          alors voilà, comme je vous ai dit pour ma part je vois une confusion
          ici :

          Dim Xlapp As Excel.Application
          Set Xlapp = GetObject(, "Excel.Application")

          je recommande plutôt comme ceci :

          Dim Xlapp As Excel.Application
          Set Xlapp = New Excel.Application

          bien entendu, il faut faudra charger la référence
          "Microsoft Excel 1X Object Library", sinon vous
          utiliser des objets de scripting qui différent de ceux
          proposé sous VBA.

          j'ai modifié votre code pour le comprendre, et le rendre fonctionnel !

          voici ce que ça me donne : 

          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
'


          Lupin
          2
          1. Ludivine50
            Bonjour à tous,

            j'essaye d'adapter ce code à mon projet, mais j'ai l'erreur d'exécution 3078: le moteur de base de données Microsoft Jet ne peut pas trouver la base de données... sur l'instruction suivante:
            Set Rs = Db.OpenRecordset("T_INTERVENTION").
            Pourtant le nom de la table est correct.

            En références, j'ai mis:

            Microsoft Excel 11. Object LIbrary
            Microsoft Office 11. Object LIbrary
            Microsoft DAO 3.6 Object LIbrary
            OLE automation....

            Est-ce qu'il en manque une? Le problème vient-il d'ailleurs?
            Je ne suis pas contre un petit coup de pouce, car je me creuse la tête depuis un sacré bout de temps...
            Ludivine
            0
          2. Utilisateur anonyme
            @Ludivine50Bonjour,

            tardivement, mais avez-vous toute la séquence de connexion ? 

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

Set Db = CurrentDb

Set Rs = Db.OpenRecordset("T_INTERVENTION")


            Lupin
            0
          3. Ludivine50
            @Utilisateur anonymeBonjour Lupin et merci pour votre réponse,
            Ce n'était pas qu'un problème de connexion en fait.
            Déjà dbo_T_INTERVENTION et T_INTERVENTION, ce n'est pas la même chose pour VB ACCESS, ce que je comprends assez bien! Mon appli Access est liée à une base de données SQL SERVER, donc j'avais "oublié" le dbo qu'il rajoute sans me demander ;-)
            Mais mon problème principal c'était la gestion des dates en fait, mais on m'a prêté une fonction qui a résolu le problème. Pour ceux que ça t'intéresses: 
            Function SQLArgDate(ByVal vDate As Date) As String
On Error Resume Next
    If Not IsNull(vDate) Then
        SQLArgDate = "#" & Format$(vDate, "mm/dd/yyyy") & "#"
    End If
End Function


            Bonne journée à tous
            0
          4. Utilisateur anonyme
            @Ludivine50re:

            tu vois, moi j'aurai ajouté l'affectation d'initialisation de la variable "Fonction" : 

            Function SQLArgDate(ByVal vDate As Date) As String
On Error Resume Next
    SQLArgDate = ""
    If Not IsNull(vDate) Then
        SQLArgDate = "#" & Format$(vDate, "mm/dd/yyyy") & "#"
    End If
End Function
'


            mais come il me fut dit, je suis perfectionniste, mais je n'aime pas
            quand ça plante, un code explicit est plus solide à mon avis.

            Lupin
            0
          5. Ludivine50
            @Utilisateur anonymeBonjour Lupin, j'ai mis en application votre réflexion.
            Moins ça plante, plus je suis contente!
            Merci beaucoup
            Bonne journée
            0
        3. PAULOM
          Merci pour votre aide j'ai fait refait le code le voici:

          [b]Option Compare Database

          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
          Dim NomFeuille As String

          On Error GoTo errOuvrirExcel
          Set Xlapp = GetObject(, "Excel.Application")
          'On Error GoTo oups:
          On Error GoTo 0
          Xlapp.Visible = True

          NomFeuille = "S" & DatePart("ww", Date)

          Set XlBook = Xlapp.Workbooks.Open("C:\Documents and Settings\A4382\Bureau\stage\Nvx_clients_par_BG_2006_S14.xls")
          If FeuilleExiste(NomFeuille, XlBook) Then
          Set XlSheet = XlBook.Worksheets("S0")
          ' 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)
          XlSheet.Range("A1").CopyFromRecordset Rs
          Set XlSheet = Nothing
          ' 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

          Function FeuilleExiste(NomFeuille As String, Classeur As Excel.Workbook) As Boolean
          Dim errNum As Long, strName As String
          errNum = 0: Err.Clear
          On Error Resume Next
          strName = Classeur.Worksheets(NomFeuille).Name
          errNum = Err.Number
          On Error GoTo 0
          If errNum = 0 Then FeuilleExiste = True Else FeuilleExiste = False
          End Function
          [/b]

          Mais j'ai un petit problème voici l'erreur:

          Il me met cette erreur:
          Erreur 91- Varaible objet ou variable de bloc with non définie

          Je pense que c'est dans cette partie :
          [b]' Copie dans feuille (nouvelle ou effacée)
          Set Rs = Db.OpenRecordset("T31_Cumul_Nvx_clients_par_BG", , dbOpenForwardOnly)
          XlSheet.Range("A1").CopyFromRecordset Rs
          Set XlSheet = Nothing
          ' remise au début car le 'CopyFromRecordset' ne le fait pas
          Rs.MoveFirst
          XlSheet.Range("A1").CopyFromRecordset Rs[/b]
          1
          1. Utilisateur anonyme
            bon...

            ceci dit, il y a peu être un autre chemin que je ne connais point !

            sachant que GetObject est un objet de scripting, j'ai toujours
            déclaré sous VBA les variables en type Variant pour toutes les
            variables utilisant les objets de "scripting".

            Dim Xlapp As Excel.Application
            Set Xlapp = GetObject(, "Excel.Application")

            en VBS sous VBA, j'écris :

            Dim Xlapp As Variant
            Set Xlapp = GetObject(, "Excel.Application")

            en VBS toutes les variables sont de Type Variant de façon native.

            Lupin
            1
            1. Utilisateur anonyme
              re:

              c'est justement le fait que cette variable soit déclaré comme objet !

              la méthode GetObject* est défini comme fonction de scripting,
              d'après moi peu importe la variable qui va l'accepter cela sera
              quand même un objet de scripting, et avec ce type de crochet
              j'ai rencontré plusieurs problèmes.

              je n'arrive pas à modifier ce lien, il attérit sur la methode
              RegRead, il suffit de visualiser la liste à gauche pour y trouver la méthode GetObject !

              * https://docs.microsoft.com/en-us/

              Lupin
              1
              1. Lust
                Faux, je dis faux... lol

                En faite, non monsieur lupin, étant donnée que la variable est déclarée comme Excel.Application
                1
                1. Utilisateur anonyme
                  Bonjour,

                  je crois qu'il y a confusion ici !

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

                  Ces variables sont utilisées ici comme dans l'instruction :

                  Set Xlapp = GetObject(, "Excel.Application")

                  et la fonction "GetObject" est une instruction qui s'adresse
                  aux objets de "scripting", vous êtes dans un environnement
                  VBA, mais lorsque que vous manipulé Xlapp, celui-ci est un
                  objet de "scripting", dans ces conditions certaines instructions
                  sont plus limités pour les paramêtres.

                  Lupin
                  1
                  1. Lust
                    plutot que de faire add tu selectionne la feuille:

                    Set XlSheet = XlBook.Sheets("S15")

                    + Ca pour la selectionner et l'afficher en premier :

                    XlSheet.Select

                    Woila
                    1
                    1. PAULOM
                      Merci pour ton aide lupin, j'ai changé tout le code pour eviter les mauvaises manips entre les differents VB, voici le nouveau: 
                      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


                      Mais j'ai un second souci,lorsque l'on crée la feuille "S15" car cette feuille existe déja en faite sur Excel mais elle est vierge car les données ne sont pas encore rentrées. C'est exactement ce que je veux faire, pas la peine de recréer une autre feuille "S15" puisqu'elle est deja existante tu vois?
                      Je veux juste copier cette table dans la feuille de mon choix.

                      Merci beaucoup j'espere que vous m'avez bien compris.

                      Bonne journée à vous.
                      1

                      Discussions similaires

                      Quick Access service
                      alain_1949

                      4 réponses