High-Tech Santé Médecine Droit-Finances

Grippe A

Que dois-je faire ?

Rechercher : dans
Par :

Exporter une table Access vers EXCEL

Dernière réponse le 2 mar 2009 à 16:56:54 PAULOM, le 20 avr 2006 à 16:19:54 
 Signaler ce message aux modérateurs

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...

Posez votre question Répondre

1

Lupin.A, le 21 avr 2006 à 01:30:34

Bonjour,

ce pourrait être cette ligne !

xlApp.ActiveWorkbook.Sheets(1).Copy After:=xlApp.ActiveWorkbook.Sheets(IndicateursSemaine![Semai­ne] + 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

   
Répondre à Lupin.A

2

PAULOM, le 21 avr 2006 à 09:39:03

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.

   
Répondre à PAULOM

3

Lust, le 21 avr 2006 à 17:51:19

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

   
Répondre à Lust

4

Lupin.A, le 22 avr 2006 à 14:58:27

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

   
Répondre à Lupin.A

5

Lust, le 23 avr 2006 à 18:14:43

Faux, je dis faux... lol

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

   
Répondre à Lust

6

Lupin.A, le 25 avr 2006 à 00:33:22

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 !

* http://msdn.microsoft.com/library/default.asp?url=/library/e­n-us/script56/html/1b...

Lupin

   
Répondre à Lupin.A

7

Lupin.A, le 25 avr 2006 à 01:11:21

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

   
Répondre à Lupin.A

8

PAULOM, le 25 avr 2006 à 09:55:58

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]

   
Répondre à PAULOM

9

Lupin.A, le 26 avr 2006 à 01:10:42

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

   
Répondre à Lupin.A

12

Ludivine50, le 21 fév 2009 à 14:09:29

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

   
Répondre à Ludivine50

13

Lupin.A, le 24 fév 2009 à 01:42:55

Bonjour,

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

   
Répondre à Lupin.A

14

Ludivine50, le 24 fév 2009 à 09:39:03
  • +4

Bonjour 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

   
Répondre à Ludivine50

15

Lupin.A, le 25 fév 2009 à 04:43:28

Re:

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

   
Répondre à Lupin.A

16

 Ludivine50, le 2 mar 2009 à 16:56:54

Bonjour Lupin, j'ai mis en application votre réflexion.
Moins ça plante, plus je suis contente!
Merci beaucoup
Bonne journée

   
Répondre à Ludivine50

10

PAULOM, le 26 avr 2006 à 15:03:19

Merci beaucoup pour votre aide lupin, je vous tiens au courant...

   
Répondre à PAULOM

11

PAULOM, le 26 avr 2006 à 16:31:01

Merci LUPIN je me suis servis de votre code pour faire fonctionner le mien.

C'est vraiment gentil de votre part!

   
Répondre à PAULOM
Posez votre question Répondre
Ils ont besoin de votre aide