|  

» Use a closed workbook as a database (DAO) using VBA in Microsoft Excel

VBA macro tip contributed by Erlandsen Data Consulting offering Microsoft Excel Application development, template customization, support and training solutions
With the procedures below you can use DAO to retrieve a recordset from a closed workbook and read/write data.
Call the procedure like this:
GetWorksheetData "C:\Foldername\Filename.xls", "SELECT * FROM [SheetName$]", ThisWorkbook.Worksheets(1).Range("A3")
Replace SheetName with the worksheet name you want to retrieve data from.
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
The macro examples assumes that your VBA project has added a reference to the DAO object library.
You can do this from within the VBE by selecting the menu Tools, References and selecting Microsoft DAO x.xx Object Library.


Rate This Tip
12 34 5
Rating: 4.33     Views: 30512
No comments have been submitted.
Click here to post comment
For Registered Users
Name
Comment Title
Comments