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.
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.