Bruk en lukket arbeidsbok som database (DAO)

Prosedyrene nedenfor kan benyttes til å hente et DAO recordset fra en lukket arbeidsbok og lese/skrive data. Bruk prosedyren slik:
GetWorksheetData "C:\Foldername\Filename.xls", "SELECT * FROM [SheetName$]", ThisWorkbook.Worksheets(1).Range("A3")
Bytt ut SheetName med navnet på det regnearket du vil hente data fra.

Sub GetWorksheetData(strSourceFile As String, strSQL As String, TargetCell As Range)
Dim db As DAO.Database, rs As DAO.Recordset, f As Integer, r As Long
    If TargetCell Is Nothing Then Exit Sub
    
    On Error Resume Next
    Set db = OpenDatabase(strSourceFile, False, True, "Excel 8.0;HDR=Yes;") ' read only
    'Set db = OpenDatabase(strSourceFile, False, False, "Excel 8.0;HDR=Yes;") ' write
    'Set db = OpenDatabase("C:\Foldername\Filename.xls", False, True, "Excel 8.0;HDR=Yes;") ' read only
    'Set db = OpenDatabase("C:\Foldername\Filename.xls", False, False, "Excel 8.0;HDR=Yes;") ' write
    On Error GoTo 0
    If db Is Nothing Then
        MsgBox "Can't find the file!", vbExclamation, ThisWorkbook.Name
        Exit Sub
    End If
    
'    ' list worksheet names
'    For f = 0 To db.TableDefs.Count - 1
'       Debug.Print db.TableDefs(f).Name
'    Next f
    
    ' open a recordset
    On Error Resume Next
    Set rs = db.OpenRecordset(strSQL)
'    Set rs = db.OpenRecordset("SELECT * FROM [SheetName$]")
'    Set rs = db.OpenRecordset("SELECT * FROM [SheetName$] WHERE [Field Name] LIKE 'A*'")
'    Set rs = db.OpenRecordset("SELECT * FROM [SheetName$] WHERE [Field Name] LIKE 'A*' ORDER BY [Field Name]")
    On Error GoTo 0
    If rs Is Nothing Then
        MsgBox "Can't open the file!", vbExclamation, ThisWorkbook.Name
        db.Close
        Set db = Nothing
        Exit Sub
    End If
    
    RS2WS rs, TargetCell
    
    rs.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing
End Sub

Sub RS2WS(rs As DAO.Recordset, TargetCell As Range)
Dim f As Integer, r As Long, c As Long
    If rs Is Nothing Then Exit Sub
    If TargetCell Is Nothing Then Exit Sub
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .StatusBar = "Writing data from recordset..."
    End With
    
    With TargetCell.Cells(1, 1)
        r = .Row
        c = .Column
    End With
    
    With TargetCell.Parent
        .Range(.Cells(r, c), .Cells(.Rows.Count, c + rs.Fields.Count - 1)).Clear ' clear existing contents
        ' write column headers
        For f = 0 To rs.Fields.Count - 1
            On Error Resume Next
            .Cells(r, c + f).Formula = rs.Fields(f).Name
            On Error GoTo 0
        Next f
        ' write records
        On Error Resume Next
        rs.MoveFirst
        On Error GoTo 0
        Do While Not rs.EOF
            r = r + 1
            For f = 0 To rs.Fields.Count - 1
                On Error Resume Next
                .Cells(r, c + f).Formula = rs.Fields(f).Value
                On Error GoTo 0
            Next f
            rs.MoveNext
        Loop
        .Rows(TargetCell.Cells(1, 1).Row).Font.Bold = True
        .Columns("A:IV").AutoFit
    End With
    
    With Application
        .StatusBar = False
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Eksempelmakroene forutsetter at ditt VBA-prosjekt har en referanse til DAO objektbiblioteket.
Dette gjøres i VBE ved ved å velge menyvalget Verktøy, Referanser og krysse av for Microsoft DAO x.xx Object Library.

Dokumentet er sist oppdatert 2001-11-11 22:16:42 Utskriftsvennlig versjon