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