hennep
hennep

Reputation: 660

Running SQL in Excel

Years ago, around the turn of the century, I wrote a class to use SQL in Excel. I needed to run SQL statements in Excel on computers without a MS Access installation and succeeded with the DAO 3.6 reference that came with the Office installation.

Years later when it failed a few times, I was able to fix it with minor changes in the code. Since 64 bits Office arrived, DAO was removed completely and today I removed the DAO reference and made it work again with

CreateObject("DAO.DBEngine.120") 

together with the "Microsoft Office XX.0 Access Database Engine" reference. I expect that to fail again within some time because MS is continually removing functionality from Office products. For the time being, we have SQL available in Excel again.

I do not have a computer available at this moment, with Office, without an Access installation. I would like to know if this still works without Access installed. Could someone give it a try?

Thanks.

How to test it:

example

Create two sheets, one with data in it and one without.

Name the sheets SheetWithData and EmptySheet, or adapt the sub below.

The sheet with data in it, needs column names in the top row.

Add the class module and test the class with this sub:

Option Explicit

Sub test()
    Dim sSql  As String
    sSql = "SELECT * FROM SheetWithData WHERE col1 = true;"
    
    Dim sql As New clsSQL4excel ' creates a database in de %temp% dir
    sql.SQL_LinkXLS
    
    sql.SQL_WriteFieldNames sSql, Worksheets("EmptySheet"), 1
    sql.SQL_Query2Sheet sSql, Worksheets("EmptySheet"), 2
    
    Set sql = Nothing
End Sub

Export the code below to a text file, clsSQL4excel.cls, and import it as a class in the Excel project:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsSQL4excel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
  
'===================================================================================
' This class needs a reference to the "Microsoft Office XX.0 Access Database Engine"
'===================================================================================

' In this class module, all DAO.XXXXX early binding variable types are replaced with a late binding Object variable
' DAO constants are no longer available without a reference to DAO 3.6, the constants below failed to work after removal of the DAO reference.
Private Const dbText = 10
Private Const dbOpenDynaset = 2
Private Const dbOpenSnapshot = 4
Private Const dbLangGeneral = ";LANGID=0x0409;CP=1252;COUNTRY=0"
  
#If VBA7 Then
    Private Declare PtrSafe Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As LongPtr, ByVal lpbuffer As String) As Long
#Else
    Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpbuffer As String) As Long
#End If

Private Const DATABASENAME = "temp.mdb"
Private Const TEMP_QUERYDEF = "qdfTemp"

Private db_path As String
Private db As Object ' DAO.Database requires a reference to the Microsoft DAO 3.6 Library which is no longer available in 64 bit office
Public DeleteDbOnTerminate As Boolean

Private Sub Class_Initialize()
    On Error GoTo EH
    Set db = Nothing
    DeleteDbOnTerminate = True
    If CreateTempDB Then
       ' database succesfully created
    End If
    On Error GoTo 0
EX: Exit Sub
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Sub Class_Initialize of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Sub
Private Sub Class_Terminate()
    On Error GoTo EH
    If Not db Is Nothing Then
       db.Close
       Set db = Nothing
       If DeleteDbOnTerminate Then
          Kill db_path ' delete database in %temp% dir
       End If
    End If
    On Error GoTo 0
EX: Exit Sub
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Sub Class_Terminate of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Sub
Private Function ConvertToAlpha(iCol As Long) As String
    ' Office 2007 compatible, max column 16384 = XFD
    ' Office 2003 max column 256 = IV
    Dim iAlpha1 As Long, iAlpha2 As Long, iAlpha3 As Long
    On Error GoTo EH
    If Application.VERSION() <= "11.0" And iCol > 256 Then ' Use Office 2007 to be able to handle more than 256 columns
       ConvertToAlpha = ""
       MsgBox "Column number exceeds 256 in Function ConvertToAlpha of Module clsSQL4excel"
       Exit Function
    End If
    iAlpha3 = Int(iCol / 676)
    If iCol Mod 676 = 0 Then
       iAlpha3 = iAlpha3 - 1
    End If
    iCol = iCol - (iAlpha3 * 676)
    iAlpha2 = Int(iCol / 26)
    If iCol Mod 26 = 0 Then
       iAlpha2 = iAlpha2 - 1
    End If
    iAlpha1 = iCol - (iAlpha2 * 26)
    If iAlpha3 > 0 Then
       ConvertToAlpha = Chr(iAlpha3 + 64)
    End If
    If iAlpha2 > 0 Then
       ConvertToAlpha = ConvertToAlpha & Chr(iAlpha2 + 64)
    End If
    If iAlpha1 > 0 Then
       ConvertToAlpha = ConvertToAlpha & Chr(iAlpha1 + 64)
    End If
    On Error GoTo 0
EX: Exit Function
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Function ConvertToAlpha of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Function
Public Function GetDBEngine() As Object
    On Error Resume Next
    Set GetDBEngine = CreateObject("DAO.DBEngine.120")
    If Err.Number <> 0 Then
       Err.Clear
       Set GetDBEngine = CreateObject("DAO.DBEngine.36")
       If Err.Number <> 0 Then
          Set GetDBEngine = CreateObject("DAO.DBEngine.35")
          Err.Clear
       End If
    End If
    On Error GoTo 0
End Function
Private Function CreateTempDB() As Boolean
    Dim strTemp As String, strUserName As String
    On Error GoTo EH
    strTemp = String(255, Chr$(0))
    GetTempPath 255, strTemp
    strTemp = Left$(strTemp, InStr(strTemp, Chr$(0)) - 1)
    If Right(strTemp, 1) = "\" Then
       strTemp = strTemp & DATABASENAME
    Else
       strTemp = strTemp & "\" & DATABASENAME
    End If
    If Dir(strTemp) <> "" Then
       Kill strTemp
    End If
    ' Set db = DAO.CreateDatabase(strTemp, dbLangGeneral)
    Set db = GetDBEngine().Workspaces(0).CreateDatabase(strTemp, dbLangGeneral)
    If Dir(strTemp) <> "" Then
       db_path = strTemp
       CreateTempDB = True
    End If
    On Error GoTo 0
EX: Exit Function
EH: If Err.Number = 70 Then
       MsgBox "Database is already in use, or access is denied (in Function CreateTempDB of Class Module clsSQL4excel)"
       Application.ScreenUpdating = True
       Application.Cursor = xlDefault
       End
    End If
    MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & "in Function CreateTempDB of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Function
Public Function SQL_Sheet2TBL(sht As Worksheet, Optional bDeleteTableWhenExists, Optional bFirstRowContainsFieldNames) As Boolean
    Dim rs As Object ' DAO.Recordset
    Dim td As Object ' DAO.TableDef
    Dim fd As Object ' DAO.Field
    Dim bTmp As Boolean, i As Long, maxrow As Long, maxcol As Long, tmp As Long, rec As Long
    On Error GoTo EH
    If IsMissing(bDeleteTableWhenExists) Then
       bTmp = True
    Else
       bTmp = CBool(bDeleteTableWhenExists)
    End If
    If bTmp And TableExists(sht.Name) Then
       db.TableDefs.Delete sht.Name
    End If
    maxrow = sht.Cells.SpecialCells(xlLastCell).Row
    maxcol = sht.Cells.SpecialCells(xlLastCell).Column
    If IsMissing(bFirstRowContainsFieldNames) Then
       bTmp = False
    Else
       bTmp = CBool(bFirstRowContainsFieldNames)
    End If
    If maxrow > 0 And maxcol > 0 Then
       Set td = db.CreateTableDef(sht.Name)
       For i = 1 To maxcol
           If bFirstRowContainsFieldNames And sht.Cells(1, i).Text <> "" Then
              Set fd = td.CreateField(ConvertToAlpha(i), dbText, 255)
              td.Fields.Append fd
              fd.Required = False
           End If
       Next i
       db.TableDefs.Append td
       Set fd = Nothing
       Set td = Nothing
       Set rs = db.OpenRecordset(sht.Name, dbOpenDynaset)
       For rec = IIf(bTmp, 2, 1) To maxrow
           rs.AddNew
           For i = 1 To maxcol
               If sht.Cells(rec, i).Text <> "" Then
                  'rs.Fields(ConvertToAlpha(i)).Value = sht.Cells(rec, i).Text
                  rs.Fields(i - 1).Value = sht.Cells(rec, i).Text
               End If
           Next i
           rs.Update
       Next rec
       rs.Close
       Set rs = Nothing
    Else
       MsgBox "No data"
    End If
    On Error GoTo 0
EX: Exit Function
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Function Sheet2TBL of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Function
Private Function TableExists(sTbl As String) As Boolean
    Dim td As Object ' DAO.TableDef
    On Error GoTo EH
    For Each td In db.TableDefs
        If td.Name = sTbl Then
           TableExists = True
           Exit Function
        End If
    Next td
    TableExists = False
    On Error GoTo 0
EX: Exit Function
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Function TableExists of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Function
Public Sub SQL_Query2Sheet(strSQL As String, sht As Worksheet, Optional StartRow As Long)
    Dim rs As Object ' DAO.Recordset
    Dim i As Integer, Row As Long, t As Single
    On Error GoTo EH
    Application.StatusBar = " Bezig met schrijven in sheet: " & sht.Name
    StartRow = IIf(StartRow = 0, 1, StartRow)
    Row = StartRow
    sht.range("A" & StartRow & ":" & ConvertToAlpha(sht.Columns.Count) & sht.Rows.Count).Clear
    Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
    t = Timer + 0.5
    sht.range("A" & StartRow).CopyFromRecordset rs
    rs.Close
    Set rs = Nothing
    On Error GoTo 0
EX: Application.StatusBar = False
    Exit Sub
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Sub SQL_Query2Sheet of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Sub
Private Sub DeleteQueryDef(sQdf As String)
    Dim qd As Object ' DAO.QueryDef
    On Error GoTo EH
    For Each qd In db.QueryDefs
        If qd.Name = sQdf Then
           db.QueryDefs.Delete sQdf
           Exit For
        End If
    Next qd
    On Error GoTo 0
EX: Exit Sub
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Sub DeleteQueryDef of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Sub
Public Sub SQL_Execute(strSQL As String)
    On Error GoTo EH
    db.Execute strSQL
EX: Exit Sub
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Sub SQL_Execute of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Sub
Public Sub SQL_LinkSheet(sSheetName As String, Optional sExcelFile As String)
    Dim wbk As Workbook, bFile As Boolean, sht As Worksheet, tbl As Object ' DAO.TableDef
    On Error GoTo EH
    If IsMissing(sExcelFile) Or sExcelFile = "" Then
       Set wbk = ActiveWorkbook
    Else
       Set wbk = Application.Workbooks.Open(sExcelFile)
       bFile = True
    End If
    For Each sht In wbk.Worksheets
        If sSheetName = sht.Name Then
           Set tbl = db.CreateTableDef(sht.Name)
           tbl.Connect = "Excel 5.0;HDR=YES;IMEX=2;DATABASE=" & wbk.FullName
           tbl.SourceTableName = sht.Name & "$"
           db.TableDefs.Append tbl
           db.TableDefs.Refresh
        End If
    Next sht
    If bFile Then
       wbk.Close
    End If
    Set tbl = Nothing
    Set sht = Nothing
    Set wbk = Nothing
    On Error GoTo 0
EX: Exit Sub
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Sub SQL_LinkSheet of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Sub
Public Sub SQL_LinkXLS(Optional vExcelFile As Variant)
   Dim wbk As Workbook, sht As Worksheet, bFile As Boolean, tbl As Object ' DAO.TableDef
   If IsMissing(vExcelFile) Then
      Set wbk = ActiveWorkbook
   Else
      Set wbk = Application.Workbooks.Open(vExcelFile)
      bFile = True
   End If
   For Each sht In wbk.Worksheets
       Set tbl = db.CreateTableDef(sht.Name)
       'tbl.Connect = "Excel 5.0;HDR=YES;IMEX=2;DATABASE=" & wbk.FullName    imex 2 results in wrong field types
       tbl.Connect = "Excel 5.0;HDR=YES;IMEX=1;DATABASE=" & wbk.FullName
       tbl.SourceTableName = sht.Name & "$"
       db.TableDefs.Append tbl
       db.TableDefs.Refresh
   Next sht
   If bFile Then
      wbk.Close
   End If
   Set tbl = Nothing
   Set sht = Nothing
   Set wbk = Nothing
End Sub
Public Sub SQL_RelinkSheet(sSheet As String, bHeader As Boolean)
   Dim sht As Worksheet, bFile As Boolean, conn() As String, i As Integer, tbl As Object ' DAO.TableDef
   For Each sht In ActiveWorkbook.Worksheets
       If sht.Name = sSheet Then
          Set tbl = db.TableDefs(sht.Name)
          conn = Split(tbl.Connect, ";")
          For i = LBound(conn) To UBound(conn)
              If Left(conn(i), 4) = "HDR=" Then
                 conn(i) = "HDR=" & IIf(bHeader, "YES", "NO")
              End If
          Next i
          tbl.Connect = conn(LBound(conn))
          For i = LBound(conn) + 1 To UBound(conn)
              tbl.Connect = tbl.Connect & ";" & conn(i)
          Next i
          db.TableDefs.Refresh
          Exit For
       End If
   Next sht
   Set tbl = Nothing
   Set sht = Nothing
End Sub
Public Sub SQL_WriteFieldNames(strSQL As String, sht As Worksheet, Optional StartRow As Long)
    Dim i As Integer, R As Long, c As Long, t As Single, rs As Object ' DAO.Recordset
    On Error GoTo EH
    StartRow = IIf(StartRow = 0, 1, StartRow)
    R = StartRow
    c = 1
    sht.range("A" & R & ":" & ConvertToAlpha(sht.Columns.Count) & R).Clear
    Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
    For i = 0 To rs.Fields.Count - 1
        sht.Cells(R, c).Value = rs.Fields(i).Name
        c = c + 1
    Next i
    rs.Close
    Set rs = Nothing
    On Error GoTo 0
EX: Application.StatusBar = False
    Exit Sub
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Sub SQL_WriteFieldNames of Class Module clsSQL4excel"
    Resume EX
    Resume ' Debug code
End Sub
Public Function SQL_Recordset(strSQL As String) As Object ' DAO.Recordset
    On Error GoTo EH
    Set SQL_Recordset = db.OpenRecordset(strSQL, dbOpenDynaset)
    On Error GoTo 0
EX: Exit Function
EH: MsgBox "Error (" & Err.Number & ") " & Err.Description & vbCrLf & vbCrLf & "in '" & Application.ActiveWorkbook.Name & "', Function SQL_Recordset of Class Module clsSQL4excel"
    Set SQL_Recordset = Nothing
    Resume EX
    Resume ' Debug code
End Function

Upvotes: 1

Views: 99

Answers (1)

hennep
hennep

Reputation: 660

The above code needs DAO which is obsolete. Microsoft originally deprecated DAO, with the last version 3.6, in favour of ADO.

So last weekend I tried to rewrite the code with ADO. The first problem I ran into was creation of the database file. With ADO, a connection with the Microsoft Jet engine is needed and the Jet engine is also deprecated. The Access Runtime could be a solution but I often work for large enterprises. The first version of this SQL class was written when I worked for a multinational that uses Windows installations with no administrator rights for their staff. Bureaucracy has taken over and I no longer even try to get anything installed, it is a waste of time. Therefore I need a way to run everything from VBA with only a minimal installation of MS-Office.

All possible solutions that I can find on the net use the “Access.Application” object and that wants to run MS-Access in the background. Unfortunately, the “cheapest” Office installation is without Access.
Maybe I need to wait another 10 years until Microsoft has discovered that too many libraries have been deprecated for the conversion to 64 bits.

If anyone has an idea, how to get this done, please let me know. I'm stuck again.

Upvotes: 0

Related Questions