Read data from a workbook using ADO

The following code reads data from closed Excel workbooks using ADO with an ODBC driver.

Purpose : Extracts data from a closed workbook to an array
Inputs : sSourceFile The path and file name of the workbook to read data from.
sRange The range reference (or named range) to read the data from.
[sSheetName] The name of the sheet to return the data from. If not specified returns
data from first sheet.
[bReturnHeadings] If True returns the Column Headings (i.e. the first row in the range).
Note: This alters the shape of the output array to an array in an array.
Outputs : Returns a 2d variant array containing the values in the specified range.
Notes : Requires a reference to the Microsoft ActiveX Data Objects library
Could also use OLEDB JET 4.0 Driver

"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sSourceFile & ";Extended Properties=""Excel 8.0;HDR=Yes"""


Function WorkbookReadRange(sSourceFile As String, sRange As String, Optional sSheetName As String, Optional bReturnHeadings As Boolean) As Variant
Dim conWkb As ADODB.Connection, rsWkbCells As ADODB.Recordset, sConString As String
Dim lThisField As Long, avResults As Variant, avHeadings As Variant

On Error GoTo ErrFailed
sConString = "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & sSourceFile
Set conWkb = New ADODB.Connection
'open connection
conWkb.Open sConString
If Len(sSheetName) Then
'Get data from specified sheet
Set rsWkbCells = conWkb.Execute("Select * from " & Chr(34) & sSheetName & "$" & sRange & Chr$(34))
Else
'Get data from first sheet
Set rsWkbCells = conWkb.Execute("Select * from " & sRange)
End If
If rsWkbCells.EOF Then
'Return a 1d array
'Get headings
ReDim avHeadings(0 To 0, 0 To rsWkbCells.Fields.Count - 1)
For lThisField = 0 To rsWkbCells.Fields.Count - 1
avHeadings(0, lThisField) = rsWkbCells.Fields(lThisField).Name
Next
WorkbookReadRange = avHeadings
Else
'Return a 2d array
If bReturnHeadings Then
'Get cells
avResults = rsWkbCells.GetRows
'Get headings
ReDim avHeadings(0 To rsWkbCells.Fields.Count - 1, 0 To 0)
For lThisField = 0 To rsWkbCells.Fields.Count - 1
avHeadings(lThisField, 0) = rsWkbCells.Fields(lThisField).Name
Next
WorkbookReadRange = Array(avHeadings, avResults)
Else
'Get cells
WorkbookReadRange = rsWkbCells.GetRows
End If
End If
'Disconnect and destroy DB objects
rsWkbCells.Close
conWkb.Close
Set rsWkbCells = Nothing
Set conWkb = Nothing
On Error GoTo 0
Exit Function

ErrFailed:
'Return error message
WorkbookReadRange = Err.Description

If conWkb.State <> adStateClosed Then
conWkb.Close
End If

Set rsWkbCells = Nothing
Set conWkb = Nothing
End Function

'Demonstration Routine
Sub Test()
Dim avCellValues As Variant, vThisCell As Variant
avCellValues = WorkbookReadRange("C:\book1.xls", "A1:B2", "Sheet1")
If IsArray(avCellValues) Then
For Each vThisCell In avCellValues
Debug.Print vThisCell
Next
End If
End Sub