Comment copier une feuille EXCEL sous ACCESS?

[PAULOM]

Bonjour à tous, voici mon problème je n'arrive pas à copier le contenu d'une feuille EXCEL dans une autre feuille EXCEL du meme classeur.



Je dois transférer une table ACCESS vers EXCEL, bon ça j'y arrive je transfère ma table ACCESS (toute les semaines) vers la feuille EXCEL (SXX) et cette feuille ainsi créer doit être copier dans le meme classeur dans la feuille S0, en gros je dois avoir 2 feuilles identiques dans le meme classeur mais sous 2 noms différents, et j'aimerais également mettre mes champs si possible.



Je met pour l'instant pour mon code si ça peut vous aider.



Je vous remercie d'avance pour votre aide.

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

Dim LigneCopiees As Long

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) - 1



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('NomFeuille')

   ' 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 - 2))

   XlSheet.Name = NomFeuille



End If



Set Db = CurrentDb



 ' Copie dans feuille (nouvelle ou effacée)



If DCount('*', 'T31_Cumul_Nvx_clients_par_BG') > 0 Then

    Set Db = CurrentDb

     ' Copie dans feuille (nouvelle ou effacée)

    Set Rs = Db.OpenRecordset('T31_Cumul_Nvx_clients_par_BG', , dbOpenForwardOnly)

    Rs.MoveFirst

    LigneCopiees = XlSheet.Range('A1').CopyFromRecordset(Rs)

     ' Ferme les Var

    Rs.Close: Set Rs = Nothing

    Db.Close: Set Db = Nothing

Else

    MsgBox 'Pas de données'

End If

 ' Ferme les Var

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

 

[MichelXld]

bonsoir

pour ajouter le nom des champs dans la 1ere ligne de la feuille Excel , tu peux essayer


'
'...
'
Set Db = CurrentDb

' Copie dans feuille (nouvelle ou effacée)
Set Rs = Db.OpenRecordset('T31_Cumul_Nvx_clients_par_BG', , dbOpenForwardOnly)

For i = 0 To Rs.Fields.Count - 1
XlSheet.Cells(1, i + 1) = Rs.Fields(i).Name
Next i

'Rs.MoveFirst
LigneCopiees = XlSheet.Range('A2').CopyFromRecordset(Rs)

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

par contre je ne comprend pas ton probleme de feuilles identiques . pourquoi n'utilises tu pas le meme type de procedure pour creer une 2eme feuille et transferer les données


bonne soirée
MichelXld

 

[PAULOM]

Merci beaucoup MichelXld ton code marche parfaitement, c'est impecable cela fait exactement ce que je voulais...
.
UN grand merci à toi!

Je met le code pour ceux que ça interesse:

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
Dim LigneCopiees As Long
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) - 1
SemPrec = 'S' & DatePart('ww', Date) - 2

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(NomFeuille)
   ' 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 - 2))
   XlSheet.Name = NomFeuille

End If
'  Worksheets('S0').Copy After:=Worksheets('S14')
Set Db = CurrentDb
 
 ' Copie dans feuille (nouvelle ou effacée)
 
If DCount('*', 'T31_Cumul_Nvx_clients_par_BG') > 0 Then
    Set Db = CurrentDb
     ' Copie dans feuille (nouvelle ou effacée)
    Set Rs = Db.OpenRecordset('T31_Cumul_Nvx_clients_par_BG', , dbOpenForwardOnly)
    For I = 0 To Rs.Fields.Count - 1
    XlSheet.Cells(1, I + 1) = Rs.Fields(I).Name
    Next I
    Rs.MoveFirst
    LigneCopiees = XlSheet.Range('A2').CopyFromRecordset(Rs)
     ' Ferme les Var
    Rs.Close: Set Rs = Nothing
    Db.Close: Set Db = Nothing
Else
    MsgBox 'Pas de données'
End If

    'copie SXX dans S0
    Sheets(NomFeuille).Select
    Range('A1:G1').Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Names.Add Name:='Semaine', RefersToR1C1:='=S16!R1C1:R111C7'
    Sheets(NomFeuille).Select
    Selection.Copy
    Sheets('S0').Select
    Range('A1:A1').Select
    ActiveSheet.Paste
    ActiveSheet.Paste
    'Copie la semaine précedente dans Semaine-1
    Sheets(SemPrec).Select
    Cells.Select
    Selection.Copy
    Sheets('Semaine S-1').Select
    Cells.Select
    ActiveSheet.Paste
    'Application.CutCopyMode = False
    Sheets('S0').Select
 ' Ferme les Var
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