DAO - DieseArbeitsmappe und externe Datei - Daten auslesen...

Frage: Per DAO Daten auslesen. Aus der Datei in welcher sich der Code befindet (also die gerade geöffnete Datei). Ergebnis sollen bestimmte Daten sein (berechnet und aufbereitet über SQL). In einem zweiten Schritt soll das gleiche mit einer geschlossenen Datei gemacht werden.

Read data via DAO. From the file in which the code is (the file you just opened). Result will be certain data (calculated and processed via SQL). In a second step, the same is to be made with a closed file.

Hier noch eine Beispieldatei / Here's a sample file:
DAO - DieseArbeitsmappe und externe Datei - Daten auslesen...[ZIP 30 KB]

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 15.10.2013
' Purpose   : DAO ThisWorkbook and external WorkBook...
'--------------------------------------------------------------------------
Sub Main()
    Dim objDatabase As Object
    Dim objRecord 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
    ' Auf Sheet2 wird alles gelöscht
    Sheet2.Cells.Clear
    ' Ab Excel 2007 nimm diese Engine und nimm
    ' DieseArbeitsmappe (ThisWorkbook) als Datenbasis
    If Val(Application.Version) >= 12 Then
        Set objDatabase = CreateObject("DAO.DBEngine.120").OpenDatabase _
            (ThisWorkbook.FullName, False, False, "Excel 8.0")
    ' Vor Excel 2007 nimm diese Engine und nimm
    ' DieseArbeitsmappe (ThisWorkbook) als Datenbasis
    Else
        Set objDatabase = CreateObject("DAO.DBEngine.36").OpenDatabase _
            (ThisWorkbook.FullName, False, False, "Excel 8.0")
    End If
    ' Fülle den Recordset basierend auf dem SQL-String
    ' Sheet1 kommt aus dem englischen Excel und muss gegebenenfalls
    ' ANGEPASST werden!
    Set objRecord = objDatabase.OpenRecordset("SELECT [Sheet1$].Name, " & _
        "[Sheet1$].Group, " & _
        "Sum([Sheet1$].Hint) AS Hint, " & _
        "AVG([Sheet1$].Hint) AS Average" & _
        " FROM [Sheet1$] GROUP BY [Sheet1$].Name, " & _
        "[Sheet1$].Group ORDER BY [Sheet1$].Name, " & _
        "[Sheet1$].Group;")
    ' Zeile 1 von Sheet1 nach Sheet2 kopieren
    Sheet1.Range("A1").EntireRow.Copy Sheet2.Range("A1")
    ' Recordset auf einen Rutsch in Sheet2 eintragen
    Sheet2.Range("A2").CopyFromRecordset objRecord
Fin:
    ' Wenn Recordset offen, dann schliessen
    If Not objRecord Is Nothing Then objRecord.Close
    ' Setze die Objektvariable auf Nothing
    Set objRecord = Nothing
    ' Wenn Datentunnel offen, dann schliessen.
    If Not objDatabase Is Nothing Then objDatabase.Close
    ' Setze die Objektvariable auf Nothing
    Set objDatabase = 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

Nachfolgend der Code für die externe geschlossene XLSX-Datei / Below is the code for the external closed xlsx file.

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module2
' Procedure : Main_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 15.10.2013
' Purpose   : DAO ThisWorkbook and external WorkBook...
'--------------------------------------------------------------------------
Sub Main_1()
    Dim strFilename As String
    Dim objDatabase As Object
    Dim objRecord 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
    strFilename = ThisWorkbook.Path & Application.PathSeparator & "DAO_SQL.xlsx"
    ' Auf Sheet3 wird alles gelöscht
    Sheet3.Cells.Clear
    ' Ab Excel 2007 nimm diese Engine und nimm
    ' DieseArbeitsmappe (ThisWorkbook) als Datenbasis
    If Val(Application.Version) >= 12 Then
        Set objDatabase = CreateObject("DAO.DBEngine.120").OpenDatabase _
            (strFilename, False, False, "Excel 8.0")
    ' Vor Excel 2007 nimm diese Engine und nimm
    ' DieseArbeitsmappe (ThisWorkbook) als Datenbasis
    Else
        Set objDatabase = CreateObject("DAO.DBEngine.36").OpenDatabase _
            (strFilename, False, False, "Excel 8.0")
    End If
    ' Fülle den Recordset basierend auf dem SQL-String
    ' Sheet1 kommt aus dem englischen Excel und muss gegebenenfalls
    ' ANGEPASST werden!
    Set objRecord = objDatabase.OpenRecordset("SELECT [Sheet1$].Name, " & _
        "[Sheet1$].Group, " & _
        "Sum([Sheet1$].Hint) AS Hint, " & _
        "AVG([Sheet1$].Hint) AS Average" & _
        " FROM [Sheet1$] GROUP BY [Sheet1$].Name, " & _
        "[Sheet1$].Group ORDER BY [Sheet1$].Name, " & _
        "[Sheet1$].Group;")
    ' Zeile 1 von Sheet1 nach Sheet2 kopieren
    Sheet1.Range("A1").EntireRow.Copy Sheet3.Range("A1")
    ' Recordset auf einen Rutsch in Sheet2 eintragen
    Sheet3.Range("A2").CopyFromRecordset objRecord
Fin:
    ' Wenn Recordset offen, dann schliessen
    If Not objRecord Is Nothing Then objRecord.Close
    ' Setze die Objektvariable auf Nothing
    Set objRecord = Nothing
    ' Wenn Datentunnel offen, dann schliessen.
    If Not objDatabase Is Nothing Then objDatabase.Close
    ' Setze die Objektvariable auf Nothing
    Set objDatabase = 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

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

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