Komfortabler Datenexport von Access nach Excel
Mit den folgenden 2 Prozeduren lassen sich auf einen Klick Daten eines Recordsets nach Excel exportieren.
Option Compare Database
Option Explicit
Public Enum genXlsFormat
xlsformat_int
xlsformat_dbl
xlsformat_date
xlsformat_currency
End Enum
Public Function ExportRstToExcel( _
pRst As Object, _
Optional strTemplatePfad As String, _
Optional pfVisible As Boolean = True, _
Optional varFieldCaptions As Variant, _
Optional bCaptionBold As Boolean, _
Optional bAutoFit As Boolean, _
Optional strRangePlace As String = "A1", _
Optional bRow1freeze As Boolean, _
Optional bAutoFilter As Boolean, _
Optional arrColumnsFormat As Variant) As Object 'Excel.Worksheet
' Erzeugt ein neues Excel-Workbook und kopiert Daten aus einem Recordset in das erste Sheet.
' - pRst: Recordset (Funktioniert mit: Form.Recordset, ADO und DAO (?)
' - pfVisible: Excel-Application sichtbar schalten
' - varFieldCaptions wenn fehlt, dann werden Spalten-Überschriften aus den Recordset-captions gebildet
' wenn false, dann gar keine Überschriften
' sonst wird ein Array aus Strings mit den gewünschten Spaltenüberschriften übergeben
' Beispiel: Array("Nummer", "Artikel", "Preis", "Datum") -> 2. Spalte bekommt Überschrift "Artikel"
' Sonderfälle:
' bei "" -> keine Caption für die entsprechende Spalte, zB.: Array("Nummer", "", "Preis", "Datum") -> 2. Spalte bekommt keine Überschrift
' wenn fehlt: unveränderte Caption, zB: Array("Nummer", , "Preis", "Datum") -> 2. Spalte bekommt Überschrift aus dem Feldnamen des Recordsets
' Empty -> Spalte wird gelöscht, zB: Array("Nummer", Empty, "Preis", "Datum") -> 2. Spalte wird komplett gelöscht
' - bCaptionBold Überschriften bold
' - bAutoFit Autofit auf Spalten
' - strTemplatePfad wenn angegeben, dann neues workbook aus template
' - strRangePlace Zelle, in die der recordset (optional mit Captions) einzufügen ist. A1, wenn nicht angegeben
' - bRow1freeze 1. Zeile fixieren
' - bAutoFilter Filter auf 1. Zeile
' - arrColumnsFormat Array mit Formaten pro Zeile. kann in der Form Array(, , xlsformat_dbl) übergeben werden
' - return Das Worksheet, in das die Daten eingefügt werden
Dim xlsApp As Object 'Excel.Application
Dim xlsWbk As Object 'Excel.Workbook
Dim xlsWs As Object 'Worksheet
Dim i As Integer
Dim bOK As Boolean
If pRst Is Nothing Then Exit Function
pRst.MoveFirst ' wenn recordset oder recordsetclone eines forms übergeben wird, dann steht sonst der Recordset beim 2. Aufruf auf EOF
If pRst.EOF Then Exit Function
' Excel-Application erzeugen
Set xlsApp = CreateObject("Excel.Application")
' Neues Workbook
If strTemplatePfad = "" Then
' blank
Set xlsWbk = xlsApp.Workbooks.Add()
Else
' aus Template
Set xlsWbk = xlsApp.Workbooks.Add(strTemplatePfad)
End If
' Daten werden in das erste Sheet exportiert
Set xlsWs = xlsWbk.worksheets(1)
bOK = ExportRstToSheet( _
xlsWs, _
pRst, _
strTemplatePfad, _
varFieldCaptions, _
bCaptionBold, _
bAutoFit, _
strRangePlace, _
bRow1freeze, _
bAutoFilter, _
arrColumnsFormat)
xlsApp.Visible = pfVisible
Set xlsApp = Nothing
Set xlsWbk = Nothing
Set ExportRstToExcel = xlsWs
Set xlsWs = Nothing
End Function
Public Function ExportRstToSheet( _
pSheet As Object, _
pRst As Object, _
Optional strTemplatePfad As String, _
Optional varFieldCaptions As Variant, _
Optional bCaptionBold As Boolean, _
Optional bAutoFit As Boolean, _
Optional strRangePlace As String = "A1", _
Optional bRow1freeze As Boolean, _
Optional bAutoFilter As Boolean, _
Optional arrColumnsFormat As Variant) As Boolean
' Kopiert Daten aus einem Recordset in ein Excel-Sheet
' - pSheet: Sheet, in das exportiert wird
' - pRst: Recordset (Funktioniert mit: Form.Recordset, ADO und DAO (?)
' - pfVisible: Mappe anzeigen
' - varFieldCaptions wenn fehlt, dann werden Spalten-Überschriften aus den Recordset-captions gebildet, sonst aus den Strings in varFieldCaptions
' wenn false, dann gar keine Überschriften
' - bCaptionBold Überschriften bold
' - bAutoFit Autofit auf Spalten
' - strTemplatePfad wenn angegeben, dann neues workbook aus template
' - strRangePlace Zelle, in die der recordset einzufügen ist. A1, wenn nicht angegeben
' - bRow1freeze 1. Zeile fixieren
' - bAutoFilter Filter auf 1. Zeile
' - arrColumnsFormat Array mit Formaten pro Zeile. kann in der Form Array(, , xlsformat_dbl) übergeben werden
' return: True, wenn erfolgreich
Dim i As Integer
Dim rngData As Object ' Range
Dim bCaptions As Boolean
Dim rngCaption As Object ' Range
Dim varCaption As Variant
Dim intRow1 As Integer
If pRst.EOF Then Exit Function
pRst.MoveFirst ' wenn recordset oder recordsetclone eines forms übergeben wird, dann wird sonst beim 2. aufruf nichts exportiert
If pRst Is Nothing Then
MsgBox "error in exporting data from recordset: no recordset"
Exit Function
End If
' Überschriften werden erzeugt, wenn varFieldCaptions fehlt oder ein Array mit Überschriften ist
bCaptions = IsMissing(varFieldCaptions) Or IsArray(varFieldCaptions)
Set rngData = pSheet.Range(strRangePlace)
intRow1 = rngData.row
If bCaptions Then
' Captions -> Daten sind eine Zeile weiter unten einzufügen
Set rngData = rngData.offset(1)
rngData.offset(-1).EntireRow.Font.Bold = bCaptionBold
End If
' daten einfügen
rngData.CopyFromRecordset pRst
If bAutoFilter Then
pSheet.Rows(intRow1).AutoFilter
End If
' Spaltenformatierungen
If Not IsMissing(arrColumnsFormat) Then
For i = 0 To UBound(arrColumnsFormat)
If Not IsMissing(arrColumnsFormat(i)) Then
Select Case arrColumnsFormat(i)
Case xlsformat_int
pSheet.Columns(rngData.Column + i).NumberFormat = "#,##0"
Case xlsformat_dbl
pSheet.Columns(rngData.Column + i).NumberFormat = "#,##0.00"
Case xlsformat_date
pSheet.Columns(rngData.Column + i).NumberFormat = "d/m/yy;@"
Case xlsformat_currency
pSheet.Columns(rngData.Column + i).NumberFormat = "#,##0.00 $"
End Select
End If
Next
End If
' Spaltenüberschriften
If bCaptions Then
For i = pRst.Fields.Count - 1 To 0 Step -1 ' Schleife von hinten her, falls Spalten gelöscht werden
Set rngCaption = pSheet.Cells(rngData.row - 1, rngData.Column + i)
If IsMissing(varFieldCaptions) Then
' Captions aus den Feldnamen
rngCaption = pRst.Fields(i).Name
ElseIf Not IsEmpty(varFieldCaptions) Then
' Captions wie übergeben
If UBound(varFieldCaptions) >= i Then ' falls im Array weniger Elemente übergeben werden als die Anzahl der Felder
varCaption = varFieldCaptions(i)
Else
varCaption = Null
End If
If IsEmpty(varCaption) Then
' Spalte löschen
rngCaption.entirecolumn.Delete
ElseIf IsMissing(varCaption) Or IsNull(varCaption) Then
' unveränderte Spaltenüberschrift
rngCaption = pRst.Fields(i).Name
ElseIf varCaption = "" Then
' keine Spaltenüberschrift
Else
' übergebene Spaltenüberschrift
rngCaption = varCaption
End If
End If
Next
End If
If bRow1freeze Then
With pSheet.Application
.ActiveWindow.SplitRow = intRow1
.ActiveWindow.FreezePanes = True
End With
End If
If bAutoFit Then
pSheet.usedrange.Columns.autofit
End If
ExportRstToSheet = True
End Function
Erläuterung:
Die Funktion ExportRstToExcel() wird mit mindestens einem Parameter, nämlich einem Recordset-Objekt, aufgerufen. Die Funktion erzeugt eine neues Excel-Application-Objekt und ein neues Workbook und fügt die Daten des Recordsets in das erste Blatt ein.
Zurückgegeben wird eine Worksheet-Objekt. Beispiel:
' Aufruf mit ADO-Recordset
ExportRstToExcel CurrentProject.Connection.Execute("Select * from tblArtikel")
Das Ganze funktioniert auch mit DAO-Recordsets:
' Aufruf mit DAO-Recordset
ExportRstToExcel CurrentDb.OpenRecordset("Select * from tblArtikel", dbOpenSnapshot)
Interessant ist besonders der Aufruf direkt mit einem Recordset eines gebundenen Formulars:
' Aufruf mit einem Form-Recordset ' Filter und Sortierung des Formulars werden übernommen ! ExportRstToExcel Me.RecordsetClone
Dies funktioniert auch mit einem Recordset einer Listbox:
' Aufruf mit einem Listbox-Recordset ExportRstToExcel lbArtikel.RecordsetClone
Ein Aufruf mit allen Parametern sieht z.B. so aus:
Dim rsADO As ADODB.Recordset
Set rsADO = CurrentProject.Connection.Execute("Select * from tblArtikel")
ExportRstToExcel _
pRst:=rsADO, _
varFieldCaptions:=Array("Nummer", "Artikel", "Preis", "Date"), _
bCaptionBold:=True, _
bAutoFit:=True, _
strRangePlace:="B2", _
bRow1freeze:=True, _
bAutoFilter:=True, _
arrColumnsFormat:=Array(, , xlsformat_currency, xlsformat_date)
Der Parameter varFieldCaptions kann vielfältig verwendet werden.
Wenn er fehlt, dann werden die Spaltentitel aus den Feldnamen des Recordsets gezogen.
Wenn FALSE übergeben wird, dann werden keine Überschriften erzeugt.
Hier noch weitere Möglichkeiten:
' Für alle Spalten wird eine Überschrift angegeben
ExportRstToExcel _
pRst:=rsADO, _
varFieldCaptions:=Array("Nummer", "Artikel", "Preis", "Date")
' Für Spalte 1 und 4 wird eine Überschrift angegeben, für Spalte 2 und 3 wird die Feldüberschrift aus dem Recordset übernommen
ExportRstToExcel _
pRst:=rsADO, _
varFieldCaptions:=Array("Nummer", , , "Date")
' Spalte 1 wird gelöscht ExportRstToExcel _ pRst:=rsADO, _ varFieldCaptions:=Array(Empty, "Artikel", "Preis", "Date")
Zum Schluss noch die Verwendung des Rückgabe-Parameters und die explizite Verwendung von ExportRstToSheet():
Dim ws As Object
Set ws = ExportRstToExcel(CurrentProject.Connection.Execute("select * from tblArtikel"), , , , True)
' Sheet umbenennen
ws.Name = "Alle Artikel"
' Neues Sheet erzeugen
With ws.Parent
.worksheets.Add
Set ws = .activesheet
End With
' Daten in das neue Sheet einfügen
ExportRstToSheet ws, CurrentProject.Connection.Execute("select * from tblArtikel where Preis > 100"), , , True
ws.Name = "Teure Artikel"
Komfortabler Datenexport nach Excel