[Access VBA] Spalten einer Abfrage auslesen

Gepostet am: Jun 15, 2013 6:19:12 PM

Kürzlich war ich mit dem Export einer Access Tabelle nach Excel, bei der komplexe Berechnungen zusätzlich angefallen sind, betraut. Herausforderung hierbei war, dass die zu exportierenden Spalten neben den Berechnungen konfigurierbar sind. Mein Ansatz dabei war, dass neben den Ergebnissen der Berechnung die zusätzlichen Spalten über eine Abfrage konfigurierbar sind. Das bedeutet, nur die Spalten, die in der Abfrage ausgewählt sind, werden exportiert. 

Ausgangslage

Ausgangslage ist eine einfache Tabelle ("Haupttabelle")

und eine Ansicht mit dem Namen "auszugebende_Spalten"

Ansatz 1: nur die Spalten festlegen

Benötigt man nur die Spaltennamen für den Export und keine Filterkriterien ist dieser Ansatz zu bevorzugen. 

Ermitteln der Anzahl der Spalten

Für das grundsätzliche Verständnis möchte ich zeigen, welche 2 Methoden es hierfür gibt:

(a) mittels RecordSet

Methode 1

Public Function Columns_Count(strTable As String) As Integer     Dim db As DAO.Database     Dim rs As DAO.Recordset     Dim iFieldCount As Integer          Set db = CurrentDb     Set rs = db.OpenRecordset("Select * from " & strTable, dbOpenSnapshot)     iFieldCount = rs.Fields.Count     Columns_Count = iFieldCount     rs.Close     db.CloseEnd Function

(b) mitteld TableDefs/QueryDefs

Da nicht von vornherein klar ist, ob der Übergabeparameter eine Tabelle oder eine Abfrage ist, muss dies unterschieden werden

Methode 2

Public Function Columns_Count2(strTable As String) As Integer     Dim db As DAO.Database     Set db = CurrentDb          'falls es eine Tabelle ist     Dim tdf As DAO.TableDef     For Each tdf In db.TableDefs         If tdf.Name = strTable Then             Columns_Count2 = db.TableDefs(strTable).Fields.Count             db.Close             Exit Function         End If     Next              'falls es eine Abfrage ist     Dim qdf As DAO.QueryDef     For Each qdf In db.QueryDefs         If qdf.Name = strTable Then             Columns_Count2 = db.QueryDefs(strTable).Fields.Count             db.Close             Exit Function         End If     NextEnd Function

Ermitteln der Spaltennamen 

Die selben Methoden kann man auch bei der Ermittlung der Spaltennamen verwenden:

Methode 1

Public Function Read_Columns(strTable As String) As Collection      Dim db As DAO.Database     Dim rs As DAO.Recordset     Dim Field As DAO.Field     Dim myColl As Collection     Set myColl = New Collection     Dim i As Integer     Dim strFieldName As String          Set db = CurrentDb     Set rs = db.OpenRecordset("Select * from " & strTable, dbOpenSnapshot)          For Each Field In rs.Fields         myColl.Add (Field.Name)     Next     rs.Close     db.Close     Set rs = Nothing     Set db = Nothing          Set Read_Columns = myColl     Set myColl = Nothing      End Function

bzw.

Methode 2

Public Function Read_Columns2(strTable As String) As Collection     Dim db As DAO.Database     Set db = CurrentDb     Dim myColl As Collection     Set myColl = New Collection     Dim Field As DAO.Field          'falls es eine Tabelle ist     Dim tdf As DAO.TableDef     For Each tdf In db.TableDefs         If tdf.Name = strTable Then             For Each Field In db.TableDefs(strTable).Fields                 myColl.Add (Field.Name)             Next             db.Close             Set db = Nothing             Set Read_Columns2 = myColl             Set myColl = Nothing             Exit Function         End If     Next              'falls es eine Abfrage ist     Dim qdf As DAO.QueryDef     For Each qdf In db.QueryDefs         If qdf.Name = strTable Then             For Each Field In db.QueryDefs(strTable).Fields                 myColl.Add (Field.Name)             Next             db.Close             Set db = Nothing             Set Read_Columns2 = myColl             Set myColl = Nothing             Exit Function         End If     NextEnd Function

v

Das Problem hierbei ist, dass bei der Abfrage die ID Spalte nicht ausgegeben wird, da diese nicht Bestandteil des der Select Abfrage ist. Das lässt sich auch nicht ändern, was damit begründet ist, dass dies auch keine Spalte iS von SQL ist:

SQL-Abfrage

SELECT Haupttabelle.[Spalte 1], Haupttabelle.[Spalte 2], Haupttabelle.[Spalte 3]FROM Haupttabelle ORDER BY Haupttabelle.ID;

Export2Excel

Da im konkreten Fall jedoch nur die Spalten ermittelt werden und nicht etwaige Sortier- und Filterkriterien übernommen werden, würde es keinen Sinn machen diese in der Ansicht zu verwenden.  Im konkreten Fall würde das folgendermaßen aussehen:

Export2Excel

Public Sub sExport2Excel1()      '(1) Ermitteln der auszugebenden Spalten     Dim myColumns As Collection     Dim myColumn As Variant     Set myColumns = Read_Columns("auszugebende_Spalten")          '(2) Erstellen einer Excel Datei     'erfordert einen Verweis auf Excel!     Dim appExcel As Excel.Application     Set appExcel = New Excel.Application     Dim wkbExcel As Excel.Workbook     Set wkbExcel = appExcel.Workbooks.Add     Dim wksExcel As Excel.Worksheet     Set wksExcel = wkbExcel.Worksheets(1)     appExcel.Visible = False          '(3) Spaltenüberschriften erstellen     Dim icounter As Integer     icounter = 1     For Each myColumn In myColumns         wksExcel.Cells(1, icounter) = CStr(myColumn)         icounter = icounter + 1     Next     'zusätzliche Spalte für das Ergebnis der Berechnung     wksExcel.Cells(1, icounter) = "Berechnung"               '(3) Auslesen des Recordsets & Übertragung ins Excel     Dim db As DAO.Database     Dim rs As DAO.Recordset     Set db = CurrentDb     Set rs = db.OpenRecordset("Select * from Haupttabelle", dbOpenSnapshot)     If rs.EOF Then Exit Sub          Dim iRow As Integer     Dim iColums As Integer     iRow = 2 'da in der ersten Spalte die Überschriften stehen          With rs         Do Until .EOF             iColumn = 1             For Each myColumn In myColumns                 wksExcel.Cells(iRow, iColumn) = (.Fields(CStr(myColumn)))                 iColumn = iColumn + 1             Next             'Berechnungen             '**************             wksExcel.Cells(iRow, iColumn) = CDbl(.Fields("Zahl 1").Value) + CDbl(.Fields("Zahl 2").Value) + CDbl(.Fields("Zahl 3").Value)             .MoveNext             iRow = iRow + 1         Loop     End With          rs.Close     db.Close          Set rs = Nothing     Set db = Nothing          '(4) Excel anzeigen     appExcel.Visible = TrueEnd Sub

Ansatz 2: Ansicht um die für die Berechnung benötigten Spalten erweitern

Ansicht programmatisch um Spalten erweitern

Mit folgender Funktion kann man eine bestehende Abfrage um die in der Collection gespeicherten Felder (Fields) einer bestimmten Ausgangstabelle (strQuellTabelle) erweitern:

Abfrage erweitern

Public Function AddFields2Query(strQuery As String, strQuellTabelle As String, Fields As Collection) As String'gibt einen SQL String zurück, der einerseits aus einer bestehenden Abfrage und zusätzlichen Feldern besteht'kann in weiterer Folge für eine temporäre Abfrage verwendet werdenDim db As DAO.Database Dim qry As DAO.QueryDef Set db = CurrentDb Set qry = db.QueryDefs(strQuery)'Abfrage erweiternDim mynewField As VariantDim AddSQL As String AddSQL = ", "For Each mynewField In Fields     '(1) überprüfen, ob das Feld schon in der Ansicht existiert     'und die Erweiterung des SQL-Befehls zusammenbauen     Dim currField As DAO.Field     Dim bInQuery As Boolean     bInQuery = False     For Each currField In qry.Fields         If CStr(currField.Name) = CStr(mynewField) Then             bInQuery = True             Exit For         End If     Next     'wenn das Feld nicht in der Tabelle existiert     If bInQuery = False Then         AddSQL = AddSQL & strQuellTabelle & ".[" & mynewField & "], "     End IfNext     'AddSQL um den letzten ", " bereinigen     AddSQL = Left(AddSQL, Len(AddSQL) - 2)          Dim oldSQL As String     oldSQL = qry.SQL     Dim ArrSQL As Variant     ArrSQL = Split(oldSQL, "FROM")     AddFields2Query = ArrSQL(0) & AddSQL & " FROM " & LTrim(ArrSQL(1))End Function

Rückgabewert ist ein String, den man beispielsweise für eine temporäre Abfrage verwenden kann.

Export2Excel

Nachfolgend ein Beispiel, wie man das ganze aussehen könnte:

Export2Excel

Public Sub sExport2Excel2()      '(1) Ermitteln der Spalten, die ausgegeben werden sollen     Dim myColumns As Collection     Dim myColumn As Variant     Set myColumns = Read_Columns("auszugebende_Spalten")          '(2) Erstellen einer Excel Datei     'erfordert einen Verweis auf Excel!     Dim appExcel As Excel.Application     Set appExcel = New Excel.Application     Dim wkbExcel As Excel.Workbook     Set wkbExcel = appExcel.Workbooks.Add     Dim wksExcel As Excel.Worksheet     Set wksExcel = wkbExcel.Worksheets(1)     appExcel.Visible = False          '(3) Spaltenüberschriften erstellen     Dim icounter As Integer     icounter = 1     For Each myColumn In myColumns         wksExcel.Cells(1, icounter) = CStr(myColumn)         icounter = icounter + 1     Next     'zusätzliche Spalte für das Ergebnis der Berechnung     wksExcel.Cells(1, icounter) = "Berechnung"          '(4) Lege die Felder fest, die für die Berechnung benötigt werden     Dim myColl As Collection     Set myColl = New Collection     myColl.Add ("Zahl 1")     myColl.Add ("Zahl 2")     myColl.Add ("Zahl 3")          '(5) ermittle die erweiterte Abfrage     Dim tmpSQL As String     tmpSQL = AddFields2Query("auszugebende_Spalten", "Haupttabelle", myColl)          '(6) Datenbank abfragen     Dim db As DAO.Database     Dim rs As DAO.Recordset     Set db = CurrentDb     Set rs = db.OpenRecordset(tmpSQL, dbOpenSnapshot)     If rs.EOF Then Exit Sub          Dim iRow As Integer     Dim iColums As Integer     iRow = 2 'da in der ersten Spalte die Überschriften stehen          With rs         Do Until .EOF             iColumn = 1             For Each myColumn In myColumns                 wksExcel.Cells(iRow, iColumn) = (.Fields(CStr(myColumn)))                 iColumn = iColumn + 1             Next             'Berechnungen             '**************             wksExcel.Cells(iRow, iColumn) = CDbl(.Fields("Zahl 1").Value) + CDbl(.Fields("Zahl 2").Value) + CDbl(.Fields("Zahl 3").Value)                          .MoveNext             iRow = iRow + 1         Loop     End With          rs.Close     db.Close          Set rs = Nothing     Set db = Nothing          '(7) Excel anzeigen     appExcel.Visible = True      End Sub