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