Frage: Aus allen Dateien (mdb) werden die Daten einer bestimmten Tabelle ausgelesen. Diese sollen in Excel ausgewertet werden. Die Feldnamen dürfen nur einmal in der ersten Zeile eingetragen werden. Wie geht das?
From all files (mdb) data from a particular table are read. This should be evaluated in Excel. The field names can be entered only once in the first line. How does it work?
Hier noch eine Beispieldatei / Here's a sample file:
DAO - alle MDB-Dateien eines Ordners auslesen...[ZIP 3 MB]
Mit Ordnerauswahldialog / With folder selection dialog:
From all files (mdb) data from a particular table are read. This should be evaluated in Excel. The field names can be entered only once in the first line. How does it work?
Hier noch eine Beispieldatei / Here's a sample file:
DAO - alle MDB-Dateien eines Ordners auslesen...[ZIP 3 MB]
OptionExplicit
'-----------------------------------------------------------------------------
' Module : Module1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 03.06.2013
' Purpose : DAO Accessdatenbank - Alle Daten in Excel ausgeben SQL...
'-----------------------------------------------------------------------------
' Getestet in Excel 2007/2010/2013 - Access muss NICHT installiert sein
' http://msdn.microsoft.com/de-de/library/office/ff965871%28v=office.14%29.aspx
SubMain()
' Dimensionieren der Variablen
DimstrMDBFileAsString
DimintCountAsInteger
DimobjDBankAsObject
DimobjRSetAsObject
DimblnTMPAsBoolean
DimstrSQLAsString
DimstrDAOAsString
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
' Das Bildschirmaktualisierung wird unterbrochen
.ScreenUpdating=False
' Ereignisroutinen werden deaktiviert
.EnableEvents=False
' Auslesen der momentanen Einstellung für die Berechnung
lngCalc=.Calculation
' Setzen der Berechnung auf "Manuell"
.Calculation=xlCalculationManual
' Eingabeaufforderungen und Warnmeldungen unterdrücken
.DisplayAlerts=False
EndWith
' Prüfe die Excelversion
IfVal(Application.Version)>=12Then
strDAO="DAO.DBEngine.120"
Else
strDAO="DAO.DBEngine.36"
EndIf
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier Sheet1 = der CodeName der Tabelle
' im deutschen Excel in der Regel Tabelle1
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithSheet1
' Einlesen des ersten Dateinamens
strMDBFile=Dir$(ThisWorkbook.Path&Application.PathSeparator&"*.mdb")
' Hier wird in einer Schleife jede mdb-Datei geöffnet
DoWhilestrMDBFile<>""
SetobjDBank=CreateObject(strDAO).OpenDatabase_
(ThisWorkbook.Path&Application.PathSeparator&strMDBFile)
' SQL String erstellen - Alle Daten aus der Tabelle "customerdata"
strSQL="SELECT * FROM customerdata"
' Fülle die Objektvariable "objRSet" mit dem RecordSet
' erstellt aus der SQL-Anweisung
SetobjRSet=objDBank.OpenRecordset(strSQL)
' Spaltenüberschriften bzw. Feldnamen EINMAL eintragen
IfblnTMP=FalseThen
ForintCount=0ToobjRSet.Fields.Count-1
.Cells(1,intCount+1).Value=objRSet.Fields(intCount).Name
NextintCount
' Überschrift Fett
.Range(.Cells(1,1),.Cells(1,4)).Font.Bold=True
blnTMP=True
EndIf
'Trage den Inhalt des Recordset ab A2 folgende ein
.Range("A"&Rows.Count).End(xlUp).Offset(1,0).CopyFromRecordsetobjRSet
' Schliesse die Datenbank
IfNotobjDBankIsNothingThenobjDBank.Close
' Setze die Objektvariablen auf Nothing
SetobjRSet=Nothing
SetobjDBank=Nothing
' Einlesen des nächsten Dateinamens
strMDBFile=Dir$()
Loop
' Ideale Breite der Spalten A - D
.Columns("A:D").AutoFit
EndWith
Fin:
' Schliesse die Datenbank
IfNotobjDBankIsNothingThenobjDBank.Close
' Setze die Objektvariablen auf Nothing
SetobjRSet=Nothing
SetobjDBank=Nothing
' Die Applikation aufwecken
WithApplication
' Bildschirmaktualisierung wieder einschalten
.ScreenUpdating=True
' Ereignisroutinen werden wieder aktiviert
.EnableEvents=True
' Setzen der Berechnung auf den gemerkten Wert
.Calculation=lngCalc
' Eingabeaufforderungen und Warnmeldungen wieder zulassen
.DisplayAlerts=True
' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
.CutCopyMode=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub
Mit Ordnerauswahldialog / With folder selection dialog:
OptionExplicit
'-----------------------------------------------------------------------------
' Module : Module1
' Procedure : Main_1
' Author : Case (Ralf Stolzenburg)
' Date : 03.06.2013
' Purpose : DAO Accessdatenbank - Alle Daten in Excel ausgeben SQL...
'-----------------------------------------------------------------------------
' Getestet in Excel 2007/2010/2013 - Access muss NICHT installiert sein
' http://msdn.microsoft.com/de-de/library/office/ff965871%28v=office.14%29.aspx
SubMain_1()
' Dimensionieren der Variablen
DimstrListingAsString
DimstrMDBFileAsString
DimintCountAsInteger
DimobjDBankAsObject
DimobjRSetAsObject
DimblnTMPAsBoolean
DimstrSQLAsString
DimstrDAOAsString
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
' Das Bildschirmaktualisierung wird unterbrochen
.ScreenUpdating=False
' Ereignisroutinen werden deaktiviert
.EnableEvents=False
' Auslesen der momentanen Einstellung für die Berechnung
lngCalc=.Calculation
' Setzen der Berechnung auf "Manuell"
.Calculation=xlCalculationManual
' Eingabeaufforderungen und Warnmeldungen unterdrücken
.DisplayAlerts=False
EndWith
' Ordnerauswahl
IffuncDirectory(strListing)<>""Then
' Prüfe die Excelversion
IfVal(Application.Version)>=12Then
strDAO="DAO.DBEngine.120"
Else
strDAO="DAO.DBEngine.36"
EndIf
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier Sheet1 = der CodeName der Tabelle
' im deutschen Excel in der Regel Tabelle1
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithSheet1
' Einlesen des ersten Dateinamens
strMDBFile=Dir$(ThisWorkbook.Path&Application.PathSeparator&"*.mdb")
' Hier wird in einer Schleife jede mdb-Datei geöffnet
DoWhilestrMDBFile<>""
SetobjDBank=CreateObject(strDAO).OpenDatabase_
(ThisWorkbook.Path&Application.PathSeparator&strMDBFile)
' SQL String erstellen - Alle Daten aus der Tabelle "customerdata"
strSQL="SELECT * FROM customerdata"
' Fülle die Objektvariable "objRSet" mit dem RecordSet
' erstellt aus der SQL-Anweisung
SetobjRSet=objDBank.OpenRecordset(strSQL)
' Spaltenüberschriften bzw. Feldnamen EINMAL eintragen
IfblnTMP=FalseThen
ForintCount=0ToobjRSet.Fields.Count-1
.Cells(1,intCount+1).Value=objRSet.Fields(intCount).Name
NextintCount
' Überschrift Fett
.Range(.Cells(1,1),.Cells(1,4)).Font.Bold=True
blnTMP=True
EndIf
'Trage den Inhalt des Recordset ab A2 folgende ein
.Range("A"&Rows.Count).End(xlUp).Offset(1,0).CopyFromRecordsetobjRSet
' Schliesse die Datenbank
IfNotobjDBankIsNothingThenobjDBank.Close
' Setze die Objektvariablen auf Nothing
SetobjRSet=Nothing
SetobjDBank=Nothing
' Einlesen des nächsten Dateinamens
strMDBFile=Dir$()
Loop
' Ideale Breite der Spalten A - D
.Columns("A:D").AutoFit
EndWith
Else
MsgBox"No directory was selected!"
EndIf
Fin:
' Schliesse die Datenbank
IfNotobjDBankIsNothingThenobjDBank.Close
' Setze die Objektvariablen auf Nothing
SetobjRSet=Nothing
SetobjDBank=Nothing
' Die Applikation aufwecken
WithApplication
' Bildschirmaktualisierung wieder einschalten
.ScreenUpdating=True
' Ereignisroutinen werden wieder aktiviert
.EnableEvents=True
' Setzen der Berechnung auf den gemerkten Wert
.Calculation=lngCalc
' Eingabeaufforderungen und Warnmeldungen wieder zulassen
.DisplayAlerts=True
' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
.CutCopyMode=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Error: "&_
Err.Number&" "&Err.Description
EndSub
PrivateFunctionfuncDirectory(strDirectoryAsString)AsString
WithApplication.FileDialog(msoFileDialogFolderPicker)
.InitialFileName=ThisWorkbook.Path&Application.PathSeparator
.Title="Directory"
.ButtonName="Auswahl..."
.InitialView=msoFileDialogViewList
If.Show=-1Then
strDirectory=.SelectedItems(1)
IfRight(strDirectory,1)<>"\"ThenstrDirectory=strDirectory&"\"
Else
funcDirectory=""
EndIf
EndWith
funcDirectory=strDirectory
EndFunction