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

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.

Leave a Reply

Your email address will not be published. Required fields are marked *

Terms and Conditions of use

The applications/code on this site are distributed as is and without warranties or liability. In no event shall the owner of the copyrights, or the authors of the applications/code be liable for any loss of profit, any problems or any damage resulting from the use or evaluation of the applications/code.