Reputation: 660
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:
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
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