Visual Basic Programming Code Examples Visual Basic > Database SQL Stuff Code Examples Read data from a closed workbook using ADO Read data from a closed 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