Abfrage nach Excel aber in mehere Excelblätter

[accessgui]

Hallo,
ich habe eine Datenbank "Abteilungen" wo die Namen der Abteilung enthalten sind.

In einer Schleife will ich eine Abfrage durchführen die alle Abteilungen als Variable vabteilung()
durchgeht.
Die Abfrage soll dann die Werte in eine Exceldatei schreiben. ABER: Es soll in eine Datei, wo jedes Blatt
der Abteilungsname ist.

1)
ein Problem wenn noch,  das vorhandene Blattnamen Probleme machen.
Zwei Möglichkeiten:
1a)beim Starten einfach die Datei löschen und neu erstellen oder
1b)alle Blätter beim starten löschen

2)Die Exceldatei einmal öffnen und dann alle Blätter füllen

Mein Anfang ist hier:
Gruss
accessgui

Code [Auswählen] Erweitern


'####################
sub starten()
Dim rs As DAO.Recordset             ' Recordsetobjekt  aus  DAO Zugriffsbibliothek
   Dim sql As String                   ' Variable für Tabellenname oder SQL-Statement

' Datenbankquelle definieren
   sql = "SELECT abteilung FROM abteilung;"
   Set rs = CurrentDb.OpenRecordset(sql, dbOpenDynaset)   ' dbOpenSnapshot für lesend
   Do While Not rs.EOF                                   ' Durchläuft alle Datensätze
       varabteilung = rs!abteilung 
    'MsgBox vabteilung()
       
    Call SaveRecordsetToExcelRange
      rs.MoveNext                      ' Wichtig! Sonst unendlicher Schleifendurchlauf
   Loop

   rs.Close
   If Not rs Is Nothing Then Set rs = Nothing       ' Wichtig, Obj. aus Speicher entf.
end sub
'###################



Private Sub SaveRecordsetToExcelRange()
'  This module requires references to the
'  following object libraries:
'
'  1. Microsoft Excel X.X Object Library,
'    where X.X is the Excel Version Number.
'
'  2. One of the following:
'
'    For mdb files:
'      Microsoft DAO 3.6 Object Library
'      (DAO360.DLL)
'    For ACCDB files (Access 2007):
'      Microsoft Office 12 Access Database Engine Objects
'      (ACEDAO.DLL)
'      This reference should be set already.
'
'  To set the reference, in the VBA editor:
'    Tools > References.
  '  Excel constants:
   Const strcXLPath As String = "C:\Temp\zabteilung.xls"
   Const strcCellAddress As String = "A1"
  'On Error Resume Next: oExcel.worksheets(ExcelTmpBlatt).Delete: On Error GoTo 0
 
  '  Access constants:

 
  '  DAO objects:
  Dim objDB As DAO.Database
  Dim objQDF As DAO.QueryDef
  Dim objRS As DAO.Recordset

  '  Excel Objects:
  Dim objXL As Object
  Dim objWBK As Object
  Dim objWS As Object
  Dim objRNG As Object
 
 
 
  On Error GoTo Error_Exit_SaveRecordsetToExcelRange
 
  '  Open a DAO recordset on the query:
  Set objDB = CurrentDb()
  Set objQDF = objDB.QueryDefs(strcQueryName)
  Set objRS = objQDF.OpenRecordset
 
  '  Open Excel and point to the cell where
  '  the recordset is to be inserted:
' Set objXL = New excel.Application
  Set objXL = CreateObject("Excel.Application")
  objXL.Visible = True
  Set objWBK = objXL.Workbooks.Open(strcXLPath)

'dieses geht auch nicht
    On Error GoTo 0
    objWBK.worksheets(strcWorksheetName).Delete:
    0:

objWBK.Worksheets.Add
objWBK.Worksheets(1).Name = vabteilung() 'hier dann der Name von der Abteilung als Blattname

Set objWS = objXL.worksheets(1)

  Set objRNG = objWS.Range(strcCellAddress)
  Set objWS = objWBK.worksheets(vabteilung())

  objRNG.CopyFromRecordset objRS
  objWBK.Save
  objXL.Quit



  '  Destroy objects:
  GoSub CleanUp
 
Exit_SaveRecordsetToExcelRange:

  Exit Sub
 
CleanUp:

  '  Destroy Excel objects:
  Set objRNG = Nothing
  Set objWS = Nothing
  Set objWBK = Nothing
  Set objXL = Nothing
 
  '  Destroy DAO objects:
  If Not objRS Is Nothing Then
    objRS.Close
    Set objRS = Nothing
  End If
  Set objQDF = Nothing
  Set objDB = Nothing
 
  Return
 
Error_Exit_SaveRecordsetToExcelRange:

  MsgBox "Error " & Err.Number _
    & vbNewLine & vbNewLine _
    & Err.Description, _
    vbExclamation + vbOKOnly, _
    "Error Information"
   
  GoSub CleanUp

 
  Resume Exit_SaveRecordsetToExcelRange

End Sub