Komfortabler Datenexport nach Excel

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
Markiert in:             

Schreibe einen Kommentar

Deine E-Mail-Adresse wird nicht veröffentlicht. Erforderliche Felder sind mit * markiert