Sunday, 5 February 2017

Using 2007 Office System Driver to query Worksheets

So many questions pop up on Stack Overflow asking how to match data that is relational, i.e. write code that mimic SQL functionality.  Here we post how ADO and the 2007 Office System Driver can be used to do queries based on worksheet data.

The first sub will write the test data which is some soccer statistics, run this once only. The second sub does the query and you will see that it successfully does a join.

Here is the standard module

Attribute VB_Name = "modADOExample"
Option Explicit


'*Tools->References : Microsoft ActiveX Data Object 2.8 Library

Sub RunOnceToSetupTestData()
    '* assumes a fresh new workbook
    Dim shNew(1 To 3) As Excel.Worksheet
    Dim lLoop As Long
    For lLoop = 1 To 3
        
        Set shNew(lLoop) = Nothing
        On Error Resume Next
        Set shNew(lLoop) = ThisWorkbook.Worksheets.Item("Sheet" & lLoop)
        
        On Error GoTo 0
        If shNew(lLoop) Is Nothing Then
            If lLoop = 1 Then
                Set shNew(lLoop) = ThisWorkbook.Worksheets.Add
            Else
                Set shNew(lLoop) = ThisWorkbook.Worksheets.Add(After:=shNew(lLoop - 1))
            End If
            shNew(lLoop).Name = ("Sheet" & lLoop)
        End If
        
    Next lLoop


    Dim sh As Excel.Worksheet: Set sh = shNew(1)
    sh.Name = "Players"

    ReDim v(1 To 5) As Variant
    v(1) = [{"Player","Club","Nationality","Goals";"Diego Costa","Chelsea","Spain",15;"Alexis Sánchez","Arsenal","Chile",15;"Jermain Defoe","Sunderland","England",14;"Zlatan Ibrahimovic","Manchester United","Sweden",14}]
    v(2) = [{"Romelu Lukaku","Everton","Belgium",14;"Harry Kane","Tottenham Hotspur","England",13;"Sergio Agüero","Manchester City","Argentina",11;"Dele Alli","Tottenham Hotspur","England",11;"Eden Hazard","Chelsea","Belgium",10}]
    v(3) = [{"Christian Benteke","Crystal Palace","Belgium",9;"Sadio Mané","Liverpool","Senegal",9;"Michail Antonio","West Ham United","England",8;"Roberto Firmino","Liverpool","Brazil",8;"Olivier Giroud","Arsenal","France",8}]
    v(4) = [{"Fernando Llorente","Swansea City","Spain",8;"Theo Walcott","Arsenal","England",8;"Troy Deeney","Watford","England",7;"Adam Lallana","Liverpool","England",7;"Salomón Rondón","West Bromwich Albion","Venezuela",7}]
    v(5) = [{"Gylfi Sigurdsson","Swansea City","Iceland",7;"","","",""}]
    Dim lRowIndex As Long: lRowIndex = 0
    Dim lChunkLoop As Long
    For lChunkLoop = 1 To 5
        Dim vWrite As Variant
        vWrite = v(lChunkLoop)
        Dim lChunkRowsCount As Long
        lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1
        sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite
        lRowIndex = lRowIndex + lChunkRowsCount
    Next
    
    Set sh = shNew(2)
    sh.Name = "Clubs"

    ReDim v(1 To 5) As Variant
    v(1) = [{"Club","Wins";"Chelsea",19;"Arsenal",14;"Manchester City",14;"Liverpool",13}]
    v(2) = [{"Tottenham Hotspur",13;"Manchester United",11;"Everton",10;"Burnley",9;"West Bromwich Albion",9}]
    v(3) = [{"West Ham United",8;"AFC Bournemouth",7;"Southampton",7;"Stoke City",7;"Watford",7}]
    v(4) = [{"Swansea City",6;"Crystal Palace",5;"Leicester City",5;"Hull City",4;"Middlesbrough",4}]
    v(5) = [{"Sunderland",4;"",""}]
    lRowIndex = 0
    
    For lChunkLoop = 1 To 5
        
        vWrite = v(lChunkLoop)
        
        lChunkRowsCount = UBound(vWrite, 1) - LBound(vWrite, 1) + 1
        sh.Cells(1, 1).Offset(lRowIndex).Resize(lChunkRowsCount, UBound(vWrite, 2) - LBound(vWrite, 2) + 1).Value2 = vWrite
        lRowIndex = lRowIndex + lChunkRowsCount
    Next
    
    shNew(3).Name = "Join"
    'ThisWorkbook.Save
End Sub

    




Sub Test2()

    Dim oConn As ADODB.Connection
    Set oConn = New ADODB.Connection
    
    Debug.Assert UBound(Split(ThisWorkbook.Name, ".")) > 0  '* Workbook needs to be saved
    
    oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
           "Data Source=" & ThisWorkbook.FullName & ";" & _
           "Extended Properties='Excel 12.0 Macro'"


    Dim rsPlayers As ADODB.Recordset
    Set rsPlayers = New ADODB.Recordset
    
    rsPlayers.Open "Select * from [Players$] AS P", oConn, adOpenStatic

    Dim rsJoinExample As ADODB.Recordset
    Set rsJoinExample = New ADODB.Recordset
    
    rsJoinExample.Open "Select P.* ,C.Wins from [Players$] AS P inner join [Clubs$] as C on P.Club=C.Club", oConn, adOpenStatic

    Dim rngOutput As Excel.Range
    Set rngOutput = ThisWorkbook.Worksheets.Item("Join").Cells(1, 1)
    
    Dim fldLoop As ADODB.Field
    Dim lIndex As Long: lIndex = 0
    For Each fldLoop In rsJoinExample.Fields
        lIndex = lIndex + 1
    
        rngOutput.Cells(1, lIndex).Value2 = fldLoop.Name
    
    Next fldLoop
    
    rngOutput.Offset(1).CopyFromRecordset rsJoinExample
    oConn.Close

End Sub

No comments:

Post a Comment