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
'####################
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