DAO - alle MDB-Dateien eines Ordners auslesen...

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]

Option Explicit
'-----------------------------------------------------------------------------
' 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
Sub Main()
    ' Dimensionieren der Variablen
    Dim strMDBFile As String
    Dim intCount As Integer
    Dim objDBank As Object
    Dim objRSet As Object
    Dim blnTMP As Boolean
    Dim strSQL As String
    Dim strDAO As String
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' 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
    End With
    ' Prüfe die Excelversion
    If Val(Application.Version) >= 12 Then
        strDAO = "DAO.DBEngine.120"
    Else
        strDAO = "DAO.DBEngine.36"
    End If
    ' 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
    With Sheet1
        ' Einlesen des ersten Dateinamens
        strMDBFile = Dir$(ThisWorkbook.Path & Application.PathSeparator & "*.mdb")
        ' Hier wird in einer Schleife jede mdb-Datei geöffnet
        Do While strMDBFile <> ""
            Set objDBank = 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
            Set objRSet = objDBank.OpenRecordset(strSQL)
            ' Spaltenüberschriften bzw. Feldnamen EINMAL eintragen
            If blnTMP = False Then
                For intCount = 0 To objRSet.Fields.Count - 1
                    .Cells(1, intCount + 1).Value = objRSet.Fields(intCount).Name
                Next intCount
                ' Überschrift Fett
                .Range(.Cells(1, 1), .Cells(1, 4)).Font.Bold = True
                blnTMP = True
            End If
            'Trage den Inhalt des Recordset ab A2 folgende ein
            .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).CopyFromRecordset objRSet
            ' Schliesse die Datenbank
            If Not objDBank Is Nothing Then objDBank.Close
            ' Setze die Objektvariablen auf Nothing
            Set objRSet = Nothing
            Set objDBank = Nothing
            ' Einlesen des nächsten Dateinamens
            strMDBFile = Dir$()
        Loop
        ' Ideale Breite der Spalten A - D
        .Columns("A:D").AutoFit
    End With
Fin:
    ' Schliesse die Datenbank
    If Not objDBank Is Nothing Then objDBank.Close
    ' Setze die Objektvariablen auf Nothing
    Set objRSet = Nothing
    Set objDBank = Nothing
    ' Die Applikation aufwecken
    With Application
        ' 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
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Mit Ordnerauswahldialog / With folder selection dialog:

Option Explicit
'-----------------------------------------------------------------------------
' 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
Sub Main_1()
    ' Dimensionieren der Variablen
    Dim strListing As String
    Dim strMDBFile As String
    Dim intCount As Integer
    Dim objDBank As Object
    Dim objRSet As Object
    Dim blnTMP As Boolean
    Dim strSQL As String
    Dim strDAO As String
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' 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
    End With
    ' Ordnerauswahl
    If funcDirectory(strListing) <> "" Then
        ' Prüfe die Excelversion
        If Val(Application.Version) >= 12 Then
            strDAO = "DAO.DBEngine.120"
        Else
            strDAO = "DAO.DBEngine.36"
        End If
        ' 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
        With Sheet1
            ' Einlesen des ersten Dateinamens
            strMDBFile = Dir$(ThisWorkbook.Path & Application.PathSeparator & "*.mdb")
            ' Hier wird in einer Schleife jede mdb-Datei geöffnet
            Do While strMDBFile <> ""
                Set objDBank = 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
                Set objRSet = objDBank.OpenRecordset(strSQL)
                ' Spaltenüberschriften bzw. Feldnamen EINMAL eintragen
                If blnTMP = False Then
                    For intCount = 0 To objRSet.Fields.Count - 1
                        .Cells(1, intCount + 1).Value = objRSet.Fields(intCount).Name
                    Next intCount
                    ' Überschrift Fett
                    .Range(.Cells(1, 1), .Cells(1, 4)).Font.Bold = True
                    blnTMP = True
                End If
                'Trage den Inhalt des Recordset ab A2 folgende ein
                .Range("A" & Rows.Count).End(xlUp).Offset(1, 0).CopyFromRecordset objRSet
                ' Schliesse die Datenbank
                If Not objDBank Is Nothing Then objDBank.Close
                ' Setze die Objektvariablen auf Nothing
                Set objRSet = Nothing
                Set objDBank = Nothing
                ' Einlesen des nächsten Dateinamens
                strMDBFile = Dir$()
            Loop
            ' Ideale Breite der Spalten A - D
            .Columns("A:D").AutoFit
        End With
    Else
        MsgBox "No directory was selected!"
    End If
Fin:
    ' Schliesse die Datenbank
    If Not objDBank Is Nothing Then objDBank.Close
    ' Setze die Objektvariablen auf Nothing
    Set objRSet = Nothing
    Set objDBank = Nothing
    ' Die Applikation aufwecken
    With Application
        ' 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
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function funcDirectory(strDirectory As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & Application.PathSeparator
        .Title = "Directory"
        .ButtonName = "Auswahl..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strDirectory = .SelectedItems(1)
            If Right(strDirectory, 1) <> "\" Then strDirectory = strDirectory & "\"
        Else
            funcDirectory = ""
        End If
    End With
    funcDirectory = strDirectory
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...