DAO - Accessdatenbank - Daten auslesen...

Frage: Aus einer Access Datenbank sollen Daten ausgelesen werden. Zum Beispiel Kundennummern ab einer bestimmten Zahl bis zu einer bestimmten Zahl. Eine bestehende Abfrage in Access kann genutzt werden.
In einem zweiten Schritt soll die gesamte Tabelle per SQL abgefragt werden.
Schließlich noch eine eigene Eingabe durch InputBoxen der jeweiligen Kundendaten.

From an Access database data should be read. For example, customer numbers from a given number up to a certain number.
An existing query in Access can be used.
In a second step, the entire table can be queried using SQL.
Finally, a special input through input boxes of the respective customer data.

Hier noch eine Beispieldatei / Here's a sample file:
DAO - Accessdatenbank - Daten auslesen...[ZIP 2.2 MB]

In der Beispieldatei sind die Access Datenbank in zwei Versionen (accdb und mdb), die Exceldatei mit dem Code in drei Versionen (xls, xlsm und xlsb) und die Exceldatei mit den Grunddaten.

In the sample file, the Access database in two versions (mdb and accdb), the Excel file with the code in three versions (xls, xlsm and xlsb) and the Excel file containing the basic data.

Option Explicit
'-----------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 01.04.2013
' Purpose   : DAO Accessdatenbank Abfrage in Excel ausgeben...
'-----------------------------------------------------------------------------
' 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 intCount As Integer
    Dim objDBank As Object
    Dim objRSet As Object
    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
    ' Hier öffne ich die Beispieldatenbank "case_sample.accdb"
    ' bzw. "case_sample.mdb"
    If Val(Application.Version) >= 12 Then
        ' Pfad- und Dateiname gegebenenfalls anpassen
        Set objDBank = CreateObject("DAO.DBEngine.120").OpenDatabase _
            (ThisWorkbook.Path & Application.PathSeparator & "case_sample.accdb")
    Else
        ' Pfad- und Dateiname gegebenenfalls anpassen
        Set objDBank = CreateObject("DAO.DBEngine.36").OpenDatabase _
            (ThisWorkbook.Path & Application.PathSeparator & "case_sample.mdb")
    End If
    ' Fülle die Objektvariable "objRSet" mit dem RecordSet
    ' erstellt aus der Auswahl-Abfrage "gk"
    Set objRSet = objDBank.OpenRecordset("gk")
    ' 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
        ' Alles löschen
        .Cells.Clear
        ' Spaltenüberschriften bzw. Feldnamen eintragen
        For intCount = 0 To objRSet.Fields.Count - 1
            .Cells(1, intCount + 1).Value = objRSet.Fields(intCount).Name
        Next intCount
        'Trage den Inhalt des Recordset ab A2 folgende ein
        .Range("A2").CopyFromRecordset objRSet
        ' Ideale Breite der Spalten A - D
        .Columns("A:D").AutoFit
        ' Überschrift Fett
        .Range(.Cells(1, 1), .Cells(1, 4)).Font.Bold = True
    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
'-----------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 01.04.2013
' Purpose   : DAO Accessdatenbank 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 intCount As Integer
    Dim objDBank As Object
    Dim objRSet As Object
    Dim strSQL 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
    ' Hier öffne ich die Beispieldatenbank "case_sample.accdb"
    ' bzw. "case_sample.mdb"
    If Val(Application.Version) >= 12 Then
        ' Pfad- und Dateiname gegebenenfalls anpassen
        Set objDBank = CreateObject("DAO.DBEngine.120").OpenDatabase _
            (ThisWorkbook.Path & Application.PathSeparator & "case_sample.accdb")
    Else
        ' Pfad- und Dateiname gegebenenfalls anpassen
        Set objDBank = CreateObject("DAO.DBEngine.36").OpenDatabase _
            (ThisWorkbook.Path & Application.PathSeparator & "case_sample.mdb")
    End If
    ' SQL String erstellen
    strSQL = "SELECT customerdata.[customer number]," & _
        "customerdata.name, customerdata.city, customerdata.Date " & _
        "FROM customerdata " & _
        "WHERE (((customerdata.[customer number])>=1000" & _
        "And (customerdata.[customer number])<=4500));"
    ' Fülle die Objektvariable "objRSet" mit dem RecordSet
    ' erstellt aus der SQL-Anweisung
    Set objRSet = objDBank.OpenRecordset(strSQL)
    ' 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
        ' Alles löschen
        .Cells.Clear
        ' Spaltenüberschriften bzw. Feldnamen eintragen
        For intCount = 0 To objRSet.Fields.Count - 1
            .Cells(1, intCount + 1).Value = objRSet.Fields(intCount).Name
        Next intCount
        'Trage den Inhalt des Recordset ab A2 folgende ein
        .Range("A2").CopyFromRecordset objRSet
        ' Ideale Breite der Spalten A - D
        .Columns("A:D").AutoFit
        ' Überschrift Fett
        .Range(.Cells(1, 1), .Cells(1, 4)).Font.Bold = True
    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
'-----------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main_2
' Author    : Case (Ralf Stolzenburg)
' Date      : 01.04.2013
' Purpose   : DAO Accessdatenbank Daten in Excel (InputBox) 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_2()
    ' Dimensionieren der Variablen
    Dim intCount As Integer
    Dim objDBank As Object
    Dim varTMP1 As Variant
    Dim objRSet As Object
    Dim varTMP As Variant
    Dim strSQL 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
    ' Abfrage der Werte - Eingabe muss zwischen 2 und 60.000 sein
    varTMP = Application.InputBox(" 2 to 60000", _
        "Input", 1000, , , , , 1)
    If varTMP <> False Then
        If varTMP >= 2 And varTMP <= 60000 Then
            ' Abfrage der Werte - Eingabe muss zwischen 2 und 60.000 sein
            varTMP1 = Application.InputBox(" 2 to 60000", _
                "Input", 4500, , , , , 1)
            If varTMP1 <> False Then
                If varTMP1 >= 2 And varTMP <= 60000 Then
                    ' Hier öffne ich die Beispieldatenbank "case_sample.accdb"
                    ' bzw. "case_sample.mdb"
                    If Val(Application.Version) >= 12 Then
                        ' Pfad- und Dateiname gegebenenfalls anpassen
                        Set objDBank = CreateObject("DAO.DBEngine.120"). _
                            OpenDatabase(ThisWorkbook.Path & _
                            Application.PathSeparator & "case_sample.accdb")
                    Else
                        ' Pfad- und Dateiname gegebenenfalls anpassen
                        Set objDBank = CreateObject("DAO.DBEngine.36"). _
                            OpenDatabase(ThisWorkbook.Path & _
                            Application.PathSeparator & "case_sample.mdb")
                    End If
                    ' SQL String erstellen
                    strSQL = "SELECT customerdata.[customer number]," & _
                        "customerdata.name, customerdata.city, customerdata.Date " & _
                        "FROM customerdata " & _
                        "WHERE (((customerdata.[customer number])>=" & varTMP & _
                        "And (customerdata.[customer number])<=" & varTMP1 & "));"
                    ' Fülle die Objektvariable "objRSet" mit dem RecordSet
                    ' erstellt aus der SQL-Anweisung
                    Set objRSet = objDBank.OpenRecordset(strSQL)
                    ' 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
                        ' Alles löschen
                        .Cells.Clear
                        ' Spaltenüberschriften bzw. Feldnamen eintragen
                        For intCount = 0 To objRSet.Fields.Count - 1
                            .Cells(1, intCount + 1).Value = _
                                objRSet.Fields(intCount).Name
                        Next intCount
                        'Trage den Inhalt des Recordset ab A2 folgende ein
                        .Range("A2").CopyFromRecordset objRSet
                        ' Ideale Breite der Spalten A - D
                        .Columns("A:D").AutoFit
                        ' Überschrift Fett
                        .Range(.Cells(1, 1), .Cells(1, 4)).Font.Bold = True
                    End With
                Else
                    MsgBox "Invalid!"
                End If
            Else
                MsgBox "Aborted!"
            End If
        Else
            MsgBox "Invalid!"
        End If
    Else
        MsgBox "Aborted!"
    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