vb@rchiv · Tipps & Tricks · Bericht / Formular nach Excel exportieren (Access)

Rubrik: Access | VB-Versionen: VBA

02.07.07

Bericht / Formular nach Excel exportieren (Access) Nur relevante Daten (nur den Detailbereich) nach EXCEL exportieren.
Autor: Richard Mittelstädt	Bewertung:	Views: 24.900
ohne Homepage	System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Standardmäßig ist für den Export von Hause aus die OutputTo-Anweisung vorgesehen:

Aktuellen Bericht nach Excel übergeben

Beispiel:

DoCmd.OutputTo acForm, Me.Name, "MicrosoftExcel(*.xls)", , True

ABER: Normalerweise enthält der Bericht / das Formular auch Textfelder im Kopfbereich. Dann erscheinen diese Textfelder als Spalten in der EXCEL-Tabelle, was jedoch meist absolut nicht erwünscht ist!

Mögliche Lösungen:

Variante 1: Dafür sorgen, dass in dem zu exportierenden Bericht/ Formular keine störenden Textfelder etc. sind.
-> zB. für den EXPORT einen extra "reduzierten" Bericht bauen.
Variante 2: Einen Woll-Sau-Code bauen, der aus dem Bericht/ Formular eine Abfrage generiert, in der nur die relevanten Felder (aus dem Detail-Bereich) ausgegeben werden. Diese Abfrage kann dann exportiert werden. Dafür hat aber kein Mensch Zeit. Schon deshalb erachte ich Variante 1 als die eigentlich bessere und sauberere Lösung.

Jedenfalls habe ich (ca. 14 Tage) nicht locker gelassen und 2 brauchbare Funktionen gebaut. Die Funktionen funktionieren ziemlich sicher, solange die RecordSource des Berichts/ Fomulars halbwegs "normal" sind. Bei Verwendung von IN SELECT , INNER JOIN, UNION kann die Sache "schiefgehen" ... Dann kann man immernoch in Richtung Variante 1 disponieren. Die Funktionen ausprobieren kostet schließlich nur wenig Zeit und kein Geld.

In der Beispiel-Datenbank (Download) kann man die Sache ausprobieren und die Module in andere Datenbanken importieren ...

 ' CODE fuer Bericht-Export (Formular-Export siehe Download)
Option Compare Database
Option Explicit

Public Function ExportAktiverBerichtTest_000034()
  Call ExportBerichtNachExcel
End Function

Public Function ExportBerichtNachExcel(Optional TRY_Filter = True, _
  Optional B_Name As String)
 
  ' ****************************************************************************
  ' Funktion exportiert den Detail-Bereich eines Berichts 
  ' "tabellarisch" nach EXCEL.
  ' Es wird die aktuelle Anzeige exportiert einschl. 
  ' Sortierung(en) und Spalten-Folge.
 
  ' PARAMETER:
  ' 
  ' TRY_Filter: Versuchen, auch Berichts-Filter zu übernehmen, falls vorhanden
  ' (funktioniert wahrscheinlich nicht bei sehr komplexen Quellen,
  ' dann auf False setzen und/oder Berichts-Filter verbieten oder
  ' Irgendwas ausdenken ....
  ' Evtl. kann man auch auf Textfelder im Kopf/Fuss verzichten und
  ' einfach den direkten (Standard-) Export anwenden ...
  ' 
  ' B_Name: Name des (geöffneten) Berichts
  ' ohne Angabe wird, falls zutreffend, der aktive Bericht verwendet.
  ' 
  ' Dazu wird eine Abfrage erstellt, exportiert und wieder gelöscht.
  ' - Wenn im Bericht befindliche berechnende Controls mit exportiert 
  '   werden sollen, kann man es mit entsprechenden Manipulationen 
  '  (s. weiter...) versuchen.
  ' 
  ' - Ähnliches gilt, wenn die Datenherkunft des Berichts etwas "komplexer" ist.
  ' 
  ' - Die Funktion sollte für alle "halbwegs normalen" Berichte funktionieren.
  '   Man kann bestimmt noch einiges gezielter manipulieren. Aber es gibt 
  '   bestimmt Berichte, bei denen der Export SO nicht geht.
  ' 
  ' - Die (lästigen) Einträge und Objekte im Kopf/Fuss ect. werden
  '   NICHT mit-exportiert.
  ' 
  ' - Die REIHENFOLGE DER SPALTEN soll korrekt exportiert werden.
  '   Die Reihenfolge für EXCEL wird aus der Controls-Auflistung des
  '   Berichts-Detailbereichs generiert.
  '   Dazu muss man nur die (betroffenen) Controls im Berichts-Detailbereich
  '   - Von LINKS nach RECHTS in den Vordergrund bringen oder
  '   - Von RECHTS nach LINKS in den Hintergrund bringen.
  '     (Im Berichts-Entwurf) .
  ' 
  ' - Als Spalten-Überschriften werden in EXCEL die Namen der Controls im 
  '   Berichts-Detailbereich verwendet.
  ' 
  ' - Für die Sortierung werden
  '   Berichts-Sortierung (.OrderBy) (wirkt zuerst) UND
  '   Source-Sortierung ( SELECT ..... ORDER BY xxxxxxx ) (zweitrangig)
  '   ermittelt und angewendet.
  ' 
  ' Empfehlung bei "Code-Meckern" (gilt allgemein):
  ' Den Verweis "Microsoft DAO 3.6 Object Library" an die 3. Stelle setzen.
  ' ****************************************************************************
 
  On Error GoTo ERR_01
  Dim rep1 As Report
  Dim AbfName As String ' Name der temp. Abfrage
  Dim B_Source ' Recordsource des akt. Berichts
  Dim SEL_PR As String ' evtl. vorhandenes SELECT mit Prädikat ALL, DISTINCT ect...
  Dim SEL_ARR() ' Dyn. Datenfeld mit zu untersuchenden SELECT-Prädikaten'
  Dim STR_ARR() ' Dyn. Datenfeld für String-Manipulationen ect.
  Dim STR_ARR2() ' -;-
  Dim rst1 As Recordset ' RecordSet aus Recordsource des akt. Berichts
  Dim strSQL As String ' SQL-String zum Erstellen der temp. Abfrage
  Dim AbfTmp As QueryDef ' zum erstellen der temp. Abfrage
  Dim qdf1 As QueryDef ' Für Abf-Schleifen-Tests
  Dim fld1 As Field ' Für Field-Schleifen-Tests
  Dim ctl As Control ' Für Controlls-Schleifen-Tests
  Dim Pos1 ' Zeichen-Position für Tests
  Dim Test_STR ' temp. TestString
  Dim i ' Zähler
  Dim Z ' Zeichen
  Dim t1, t2, t3 ' Texte
  Dim bFound As Boolean
 
  ' --- B_Name akt. Bericht ermitteln, falls nicht angegeben ----
  If Len(B_Name) = 0 Then
    If Not Screen.Application.CurrentObjectType = acReport Then
      MsgBox "1. Es ist kein Kein BerichtsName angegeben." & vbNewLine & vbNewLine & _
        Space(29) & "&" & vbNewLine & vbNewLine & _
        "2. Das aktive Objekt ist kein Bericht." & vbNewLine & vbNewLine
      Exit Function
    Else
      ' --- B_Name wird Name des aktiven Berichts ----
      B_Name = Screen.Application.CurrentObjectName
    End If
  End If
 
  For Each rep1 In Reports
    If rep1.Name = B_Name Then 
      bFound = True: Exit For
  Next rep1
  If Not bFound Then
    MsgBox "Bericht " & B_Name & " ist nicht geöffnet " & _
      (oder existiert nicht ?) !", vbInformation
    Exit Function
  End If
 
  B_Source = rep1.RecordSource ' Gibt FeldNamen der orig. Herkunft
  If Trim(B_Source) = "" Then
    MsgBox rep1.Name & " hat keine Datenherkunft !", vbInformation
    Exit Function
  End If
 
  ' Datensatzgruppe öffnen.
  Set rst1 = CurrentDb.OpenRecordset(B_Source, dbOpenSnapshot) 
  i = rst1.RecordCount
  rst1.Close
  If i = 0 Then
    MsgBox rep1.Name & " hat keine aktuellen Datensätze !", vbInformation
    Exit Function
  End If
 
  ' --- Name-String ermitteln für evtl. zu erzeugende (temporäre) Abfrage ---
  ' --- (Wird auch der angebotene EXCEL-Tabellen-Name ) ---
  If "x" & Environ("COMPUTERNAME") = "x" Then
    AbfName = B_Name & "_" & "Admin" 'Notlösung
  Else
    AbfName = B_Name & "_" & Environ("COMPUTERNAME")
  End If
 
  ' Datensatzgruppe öffnen.
  Set rst1 = CurrentDb.OpenRecordset(B_Source, dbOpenSnapshot)
  ' Entsprechend der Controls im Berichts-Detailbereich (Von links 
  ' nach rechts) aus deren ControlSource SQL-String entwickeln.
 
  ' Dyn. Datenfeld mit zu untersuchenden SELECT-Prädikaten (in logischer Folge !)
  ReDim SEL_ARR(5) 
  SEL_ARR(1) = "SELECT DISTINCTROW "
  SEL_ARR(2) = "SELECT DISTINCT "
  SEL_ARR(3) = "SELECT TOP "
  SEL_ARR(4) = "SELECT ALL "
  SEL_ARR(5) = "SELECT "
  For i = 1 To UBound(SEL_ARR, 1)
    If InStr(1, B_Source, SEL_ARR(i)) > 0 Then
      strSQL = SEL_ARR(i)
      Exit For
    End If
  Next i
  If Len(strSQL) = 0 Then
    strSQL = "SELECT " ' "Normaler" Klausel-Anfang
  End If
  ' Control-Reihenfolge aus Bericht
  For Each ctl In rep1.Section(acDetail).Controls 
    If ctl.ControlType = acTextBox Or _
      ctl.ControlType = acComboBox Then
      For Each fld1 In rst1.Fields ' jedes Herkunfts-Feld
        If fld1.Name = ctl.ControlSource Then
          ' Control-Name gibt EXCEL-Spalten-Namen
          If ctl.Name = ctl.ControlSource Then
            ' 2006-10-22 Feldeigenschaften SourceTable SourceField nutzen !!!
            strSQL = strSQL & "[" & fld1.SourceTable & "]" & "." & _
              "[" & fld1.SourceField & "]" & ", "
          Else
            ' 2006-10-22 Feldeigenschaften SourceTable SourceField nutzen !!!
            strSQL = strSQL & "cVar(" & "[" & fld1.SourceTable & "]" & "." & _
              "[" & fld1.SourceField & "]" & ")" & " AS " & ctl.Name & ", "
          End If
          Exit For
        Else
          ' (Hier KANN man MANIPULIEREN, wenn's geht und was nützt...)
          ' Wahrscheinlich ein berechnendes Control (mit "=" links, ist 
          ' evtl. Funktion ect.)
          ' mal versuchen....
          Test_STR = ctl.ControlSource
          If Left(Test_STR, 1) = "=" Then
            Test_STR = Right(Test_STR, Len(Test_STR) - 1) ' links = wegnehmen
            strSQL = strSQL & Test_STR & " AS " & ctl.Name & ", "
            Exit For
          End If
        End If
      Next fld1
    End If
  Next ctl
  rst1.Close
 
  ' Das letzte Komma und Leerzchn. wegschneiden!
  strSQL = Left(strSQL, Len(strSQL) - 2) 
  strSQL = strSQL & " FROM "
    ' in strSQL Stehen jetzt alle notwendigen Feldnamen in richtiger ReihenFolge:
    ' SELECT ...... FROM ohne den noch notwendigen Rest.
 
    ' --- Ist die Herkunft eine SELECT-Klausel oder Tabelle/Abfrage ?
    Pos1 = InStr(1, B_Source, "SELECT ")
    If Pos1 = 1 Then
     ' Berichts-Herkunft ist eine Select-Klausel -> Tab/Abf- Name 
     'nach "FROM" rausfiltern:
     Pos1 = InStr(1, B_Source, " FROM ")
 
     If Pos1 = 0 Then
       MsgBox "Fehler, SELECT ohne FROM in Berichts-Source ...???"
       Exit Function
     End If
    ' An strSQL (=alles bis einschl. FROM)
    ' den rechten Teil der Berichts-RecordSorce (=alles nach FROM) anfügen:
    strSQL = strSQL & " " & Right(B_Source, Len(B_Source) - Pos1 - 5)
 
    ' --- evtl. linke und rechte Leerzeichen streichen !!!! ---
    strSQL = Trim(strSQL)
    ' --- evtl. rechtes ; streichen !!!! ---
    If Right(strSQL, 1) = ";" Then strSQL = Left(strSQL, Len(strSQL) - 1)
    ' Eigentlich ist jetzt alles komplett : SELECT...FROM... WHERE ...ORDER BY ...
    ' Weil im Bericht Sortierung .OrderBy vorrangig vor ORDER BY wirkt,
    ' wird erst mal ORDER BY weggeschnitten .
    ' Nachher werden dann nacheinander BEIDE Sortierungen angefügt.
    Pos1 = InStr(1, strSQL, " ORDER BY ")
    If Pos1 > 0 Then strSQL = Left(strSQL, Pos1)
  Else
    ' RecordSource ist NUR ein einzelner Tabellen-/Abf-Name
    strSQL = strSQL & " " & B_Source
  End If
 
  ' Abfrage löschen, falls beim letzten mal nicht gelöscht werden konnte !
  For Each qdf1 In CurrentDb.QueryDefs
    If qdf1.Name = AbfName Then
      CurrentDb.QueryDefs.Delete AbfName
    End If
  Next qdf1
 
  ' Sortierung ermitteln, Berichts-Sortierung geht vor Berichts-Source-Sortierung
  ' Deshalb zuerst eventuelle Berichts-Sortierung ermitteln:
  Test_STR = ""
  If Len(rep1.OrderBy) > 0 And rep1.OrderByOn = True Then
    ' --- Sortier-Terme ermitteln -----
    STR_ARR = Array(rep1.OrderBy) ' Doll,speichern aller Sortierungen..
    For i = 0 To UBound(STR_ARR, 1)
      ReDim Preserve STR_ARR2(4, i + 1)
 
      STR_ARR2(0, i + 1) = STR_ARR(i) ' Ganzer Term in 0-Spalte'
      STR_ARR2(1, i + 1) = STR_ARR(i) ' Ganzer Term in 1-Spalte'
      STR_ARR2(2, i + 1) = STR_ARR(i) ' Ganzer Term in 2-Spalte'
 
      Pos1 = InStr(1, STR_ARR(i), ".")
      If Pos1 > 0 Then
        ' Kürzen,Herk.-Form Abf-entfernen
        STR_ARR2(1, i + 1) = Right(STR_ARR(i), Len(STR_ARR(i)) - Pos1)
        STR_ARR2(2, i + 1) = STR_ARR2(1, i + 1)
      End If
      STR_ARR2(2, i + 1) = ErsetzenTextTeil_03(STR_ARR2(2, i + 1), _
        "[", "") 'FeldName ohne "["'
      STR_ARR2(2, i + 1) = ErsetzenTextTeil_03(STR_ARR2(2, i + 1), _
        "]", "") 'FeldName ohne "]"'
 
      ' evtl. DESC raus aus 2-Spalte und merken in 3-Spalte
      Pos1 = InStr(1, STR_ARR2(2, i + 1), " DESC")
      If Pos1 > 0 Then
        ' 2-Spalte ohne " DESC"
        STR_ARR2(2, i + 1) = ErsetzenTextTeil_03(STR_ARR2(2, i + 1), " DESC", "")
        ' DESC merken in 3-Spalte
        STR_ARR2(3, i + 1) = "DESC"
      End If
      ' Z = Z & STR_ARR2(0, i + 1) & "; " & STR_ARR2(1, i + 1) & "; " & _
      '   STR_ARR2(2, i + 1) & "; " & STR_ARR2(3, i + 1) & vbNewLine
    Next i
    ' MsgBox Z
    ' Feldinhalte von STR_ARR2 sehen jetzt zB. so aus:
    ' STR_ARR2(0,1) [Abf_TestTab].[Text1] DESC
    ' STR_ARR2(1,1) [Text1] DESC 'wird später verwendet !
    ' STR_ARR2(2,1) Text1 '=Feldname ! (sum suchen der SourceTab)
    ' STR_ARR2(3,1) DESC
    ' STR_ARR2(4,1) (SourceTable, noch leer) 'wird später verwendet !
 
    ' ---- SourceTable-Namen für die Felder ermitteln ------------
    ' Datensatzgruppe öffnen.
    Set rst1 = CurrentDb.OpenRecordset(B_Source, dbOpenSnapshot) 
    For i = 1 To UBound(STR_ARR2, 2)
      ' Z = Z & STR_ARR2(0, i) & "; " & STR_ARR2(1, i) & "; " & _
      '   STR_ARR2(2, i) & "; " & STR_ARR2(3, i) & "; "
      For Each fld1 In rst1.Fields
        If fld1.Name = Trim(STR_ARR2(2, i)) Then
          STR_ARR2(4, i) = fld1.SourceTable
          Exit For
          ' Z = Z & STR_ARR2(4, i) & "; "
        End If
      Next fld1
      ' Z = Z & vbNewLine
    Next i
    rst1.Close
    ' MsgBox Z
    ' ---- ORDER - String aus Source-Tabellen und Feldnamen bilden -------
    For i = 1 To UBound(STR_ARR2, 2)
      Test_STR = Test_STR & "[" & STR_ARR2(4, i) & "]" & "." & STR_ARR2(1, i) & ", "
    Next i
    Test_STR = Trim(Test_STR) ' rechtes Leerz. wegnehmen
    If Right(Test_STR, 1) = "," Then
      Test_STR = Left(Test_STR, Len(Test_STR) - 1) ' rechtes Komma wegnehmen
    End If
    ' MsgBox Test_STR
  End If
 
  ' Erst jetzt eventuelle Sortierung aus Berichts-Source ermitteln + anhängen:
  Pos1 = InStr(1, B_Source, " ORDER BY ")
  If Pos1 > 0 Then
    If Len(Test_STR) > 0 Then
      Test_STR = Test_STR & "," ' Komma für die folgende Erweiterung
    End If
    Test_STR = Test_STR & " " & Right(B_Source, Len(B_Source) - Pos1 - 9)
  End If
  ' MsgBox strSQL & " " & Test_STR
 
  ' ---- Übernahme der ermittelten beiden Sortierungen ----
  If Len(Test_STR) > 0 Then
    ' aktuelle Sortierung übernehmen:
    strSQL = strSQL & " ORDER BY " & Test_STR
  End If
 
  ' Filter ? Jetzt wird es noch confuser, aber es geht und danach ist Schluss
  ' Evtl. ist im Bericht ein Filter aktiviert. Dieser Filter lässt sich zwar per
  ' Set prp1 = qdf1.CreateProperty("Filter", dbText) in die Abfrage einbauen,
  ' ist jedoch nicht wirksam, auch nicht mit neu erstellter FilterOn-Eigenschaft.
  ' Die Filter-Eigenschaft bei Abfragen dient wohl nur zum Vererben auf neue Formulare...
  ' 
  ' Also wird jetzt mühselig versucht,
  ' den Berichts-Filter in den WHERE-Abschnitt von strSQL einzubauen:
  ' (SELECT und FROM sind auf jeden Fall bereits in strSQL .)
  ' 
  ' - WHERE bereits vorhanden --> Filter + " AND " direkt hinter "WHERE "
  ' - WHERE nicht vorhanden --> WHERE und Filter hinter "FROM <TabAbfName> "
  ' *************************************************************************************
 
  If TRY_Filter = False Then GoTo END_FILTER    ' nicht notwendig
  If rep1.FilterOn = False Then GoTo END_FILTER ' nicht notwendig
  If Len(rep1.Filter) = 0 Then GoTo END_FILTER  ' nicht notwendig
 
  Pos1 = InStr(1, strSQL, " WHERE ")
  If Pos1 > 0 Then
    ' MsgBox " WHERE vorhanden"
    ' WHERE vorhanden, Filter + " AND " direkt hinter "WHERE " (erstes Vorkommen ersetzen)
    strSQL = ErsetzenTextTeil_04(strSQL, " WHERE ", " WHERE " & rep1.Filter & " AND ")
  Else
    ' WHERE noch NICHT vorhanden, WHERE und Filter hinter "FROM <TabAbfName> " einfügen
    ' -> Tab/Abf-Name ermitteln:
    Pos1 = InStr(1, strSQL, " FROM ") 'Pos erstes " FROM " ermitteln, muss existieren !
 
    Pos1 = Pos1 + 6 ' An dieser Pos. sollte der Tab/Abf-Name anfangen
    Do Until Not Mid(strSQL, Pos1, 1) = " "
      ' Sicherheit An Genau dieser Pos. muss der Tab/Abf-Name anfangen
      Pos1 = Pos1 + 1 
    Loop
    i = 0
    Test_STR = ""
    ' Bis " " oder Ende von strSQL
    Do Until Mid(strSQL, Pos1, 1) = " " Or Mid(strSQL, Pos1, 1) = "" 
      i = i + 1
      ' MsgBox "Herkunft: " & Chr(34) & Test_STR & Chr(34)
      ' Name der Herkunfts-Tab/Abf ergänzen
      Test_STR = Test_STR & Mid(strSQL, Pos1, 1) 
      Pos1 = Pos1 + 1
      If i > 55 Then
        t1 = "-------- FEHLER Überlauf bei Filter-Übernahme ! -----------------" & _
         vbNewLine & vbNewLine
        t2 = "ExportBerichtNachExcel(Optional ...):" & vbNewLine
        t3 = "Konnte Herkunfts-Tabelle/Abfrage-Namen nich ermitteln" & _
          vbNewLine & vbNewLine
 
        MsgBox Chr(34) & Test_STR & Chr(34) & vbNewLine & strSQL
        MsgBox t1 & t2 & t3, vbCritical
        Exit Function
      End If
    Loop
    ' In Test_STR steht jetzt der Name der Herkunfts-Tab/Abf
    ' zwischen FROM u. <Tab/AbfName> können tatsächlich 1 oder 2 Leerzeichen sein ...
    If InStr(1, strSQL, " FROM " & Test_STR) > 0 Then
      ' MsgBox "1 Leerzeichen zwischen FROM u. <Tab/AbfName>"
      ' Filter anfügen... (erstes Vorkommen ersetzen)
      strSQL = ErsetzenTextTeil_04(strSQL, " FROM " & Test_STR, " FROM " & _
        Test_STR & " WHERE " & rep1.Filter & " ")
    ElseIf InStr(1, strSQL, " FROM " & Test_STR) > 0 Then
      ' MsgBox "2 Leerzeichen zwischen FROM u. <Tab/AbfName>"
      ' Filter anfügen... (erstes Vorkommen ersetzen)
      strSQL = ErsetzenTextTeil_04(strSQL, " FROM " & Test_STR, " FROM " & _
        Test_STR & " WHERE " & rep1.Filter & " ")
    End If
  End If
 
END_FILTER:
 
  ' *********************************************************************
  ' --- ENDLICH die Abfrage für den Export erstellen mit allem PiPaPo ---
  Set AbfTmp = CurrentDb.CreateQueryDef(AbfName)
  With AbfTmp
    .SQL = strSQL
  End With
  ' *********************************************************************
 
  ' ---- EXCEL mit neuer Tabelle öffnen -----------
  DoCmd.OutputTo acOutputQuery, AbfName, acFormatXLS, , True
 
  ' Abfrage löschen! (wird sonst alles beim nächsten mal sehr langsam !
  For Each qdf1 In CurrentDb.QueryDefs
    If qdf1.Name = AbfName Then
      CurrentDb.QueryDefs.Delete AbfName
    End If
  Next qdf1
  Exit Function
 
ERR_01:
  Select Case Err.Number
    Case 2302 ' Fehler, EXCEL-Datei offen ...
      MsgBox "ExportBerichtNachExcel(Optional ...): " & vbNewLine & _
        Err.Number & " " & Err.Description & vbNewLine & vbNewLine & _
        "(Datei bereits offen ...? )"
      Resume Next
 
    Case 2501 ' Tabelle Speichern Abgebrochen...
      Resume Next
 
    Case Else
      MsgBox "ExportBerichtNachExcel(Optional ...): " & vbNewLine & _
        Err.Number & " " & Err.Description
  End Select
End Function