Here's the VBA code that allows you to read an Excel range using a SQL text driver. This is a rather complicated example, but I assume that you came here because you are a rather advanced user with a more difficult problem than the examples that we see on other sites.
Before publishing the code in its entirety, here is the original “usage example” comment in the main function, FetchXLRecordSet :
'Usage example:
''
'Set rst = FetchXLRecordSet (SQL, "TableAccountLookup", "TableCashMap")
''
"If the query uses two named ranges," TableAccountLookup "and" TableCashMap ",
', as shown in this SQL statement:
''
' SELECT
'B.Legal_Entity_Name, B.Status,
'SUM (A.USD_Settled) Like Settled_Cash
'FROM
'[TableAccountLookup] AS A,
'[TableCashMap] AS B
'WHERE
'A.Account IS NOT NULL
'AND B.Cash_Account IS NOT NULL
'AND A.Account = B.Cash_Account
' GROUP BY
'B.Legal_Entity_Name,
'B.Status
This is inconvenient, forcing you to name the tables (or list the full range of addresses) when you run the query, but it simplifies the code.
Option Explicit Optional Module
"ADODB data lookup functions for Excel support
'Online link for connection strings:' http://www.connectionstrings.com/oracle#p15
'Online link for ADO objects and properties:' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx
'External dependencies:
'Scripting - C: \ Program files \ scrrun.dll' ADO - C: \ Program files \ Common \ system \ ado \ msado27.tlb
Private m_strTempFolder As String Private m_strConXL As String Private m_objConnXL As ADODB.Connection
Public property Get XLConnection () As ADODB.Connection GoTo ErrSub Error Error
“Excel database drivers have memory problems, so we use the text driver 'to read the csv files in a temporary folder. We populate these files from the' ranges defined for use as tables with the FetchXLRecordSet () function.
Dim objFSO As Scripting.FileSystemObject
Install objFSO = New script; .FileSystemObject Install m_objConnXL = New ADODB.Connection
'Specify and clear the temporary folder:
m_strTempFolder = objFSO.GetSpecialFolder (2) .ShortPath
If Right (m_strTempFolder, 1) <> "\" Then m_strTempFolder = m_strTempFolder and "\" End If
m_strTempFolder = m_strTempFolder and "XLSQL"
Application.DisplayAlerts = False
If objFSO.FolderExists (m_strTempFolder) Then objFSO.DeleteFolder m_strTempFolder End If
If not objFSO.FolderExists (m_strTempFolder) Then objFSO.CreateFolder m_strTempFolder End If
If Right (m_strTempFolder, 1) <> "\" Then m_strTempFolder = m_strTempFolder and "\" End If
'JET OLEDB text driver connection string:' Provider = Microsoft.Jet.OLEDB.4.0; Data Source = c: \ txtFilesFolder \; Advanced Properties = "text; HDR = Yes; FMT = Delimited";
'ODBC driver connection string:' Driver = {Microsoft Text Driver (* .txt; * .csv)}; Dbq = c: \ txtFilesFolder \; Extensions = asc, csv, tab, txt;
m_strConXL = "Provider = Microsoft.Jet.OLEDB.4.0; Data source =" and m_strTempFolder and ";" m_strConXL = m_strConXL and "Extended Properties =" and Chr (34) and "text; HDR = Yes; IMEX = 1" and Chr (34) and ";"
With m_objConnXL .CursorLocation = adUseClient .CommandTimeout = 90 .ConnectionString = m_strConXL .Mode = adModeRead End with
If m_objConnXL.State = adStateClosed Then Application.StatusBar = "Connect to local Excel tables" m_objConnXL.Open End If
Set XLConnection = m_objConnXL
ExitSub: Application.StatusBar = False Exit Property
ErrSub: MsgPopup "Error connecting to local Excel data. Contact application support.", VbCritical + vbApplicationModal, "Error connecting to database!", 10 Summary ErrEnd 'Resume ExitSub ErrEnd: Terminal terminal error. Halt. Final property
Open Sub CloseConnections ()
On error Continue on
Set m_objConnXL = Nothing
End sub
Public function FetchXLRecordSet (ByVal SQL As String, ParamArray TableNames ()) Like ADODB.Recordset "This allows you to retrieve data from Excel ranges using SQL. You 'need to pass additional parameters that define each range that you use as a table', so that these ranges can be saved as csv files in the temporary "XLSQL" folder
'Please note that your query must use the' table 'naming conventions required by Excel': http://www.connectionstrings.com/excel#20
On error Continue on
Dim i As Integer Dim iFrom As Integer Dim strRange As String Dim j As Integer Dim k As Integer
If IsEmpty (TableNames) Then TableNames = Array ("") End If
If InStr (TypeName (TableNames) "," (") <1 Then TableNames = Array (TableNames) End If
Set FetchXLRecordSet = New ADODB.Recordset
With FetchXLRecordSet
.CacheSize = 8 Set.ActiveConnection = XLConnection
iFrom = InStr (8, SQL, From, vbTextCompare) + 4
For i = LBound (table names) for UBound (table names)
strRange = "strRange = TableNames (i)
If strRange = "0" or strRange = "" Then j = InStr (SQL, "FROM") + 4 j = InStr (j, SQL, "[") k = InStr (j, SQL, "]") strRange = Mid (SQL, j + 1, k - j - 1) End If
RangeToFile strRange SQL = Left (SQL, iFrom) and Replace (SQL, strRange, strRange and ".csv", iFrom + 1, 1) SQL = Replace (SQL, ". Csv", ". Csv") SQL = Replace ( SQL, ". Csv $", ". Csv") SQL = Replace (SQL, ". Csv.csv", ". Csv")
Next i
.Open SQL, adOpenStatic, adCmdText + adAsyncFetch
i = 0 Do While.State> 1 i = (i + 1) Mod 3 Application.StatusBar = "Database Connection" and String (i, ".") Sleep 250 Loop
Finish with
Application.StatusBar = False
Final function
Public function ReadRangeSQL (SQL_Range As Excel.Range) As String
'Read the range in a row. "Each line is limited to carriage returns and line breaks. Empty cells are merged into a line as" tabs "of four spaces.
"NH Feb 2018: You cannot return more than 32767 characters in a range.
Dim i As Integer Dim j As Integer Dim arrCells as a variant Dim arrRows () As String Dim arrRowX () As String Dim strRow As String Dim boolIndent As Boolean
Const SPACE As String * 1 = "" Const SPACE4 As String * 4 = "" Const MAX_LEN As Long = 32767
arrCells = SQL_Range.Value2
If InStr (TypeName (arrCells), "(") Then
ReDim arrRows (LBound (arrCells, 1) To UBound (arrCells, 1)) ReDim arrRowX (LBound (arrCells, 2) To UBound (arrCells, 2))
For i = LBound (arrCells, 1) To UBound (arrCells, 1) - 1
boolIndent = True For j = LBound (arrCells, 2) To UBound (arrCells, 2)
If isError (arrCells (i, j)) Then SQL_Range (i, j). Calculate End If
If Not isError (arrCells (i, j)) Then arrRowX (j) = arrCells (i, j) else arrRowX (j) = vbNullString End If
If boolIndent And arrRowX (j) = "" Then arrRowX (j) = SPACE4 else boolIndent = False End If
Next j
arrRows (i) = Join (arrRowX, SPACE)
If Len (Trim $ (arrRows (i))) = 0 Then arrRows (i) = vbNullString still arrRows (i) = RTrim $ (Join (arrRowX, SPACE)) End If
Next i
Erase arrCells Erase arrRowX
ReadRangeSQL = Join (arrRows, vbCrLf)
Erase arrRows
ReadRangeSQL = Replace (ReadRangeSQL, vbCrLf and vbCrLf, vbCrLf)
more ReadRangeSQL = CStr (arrCells) End If
If Len (ReadRangeSQL)> MAX_LEN Then
'Disabling interrupt spaces from each line: Do While InStr (1, ReadRangeSQL, SPACE and vbCrLf, vbBinaryCompare)> 0 ReadRangeSQL = Replace (ReadRangeSQL, SPACE and vbCrLf, vbCrLf) Loop
End if
If Len (ReadRangeSQL)> MAX_LEN Then
"Reduce the tab size to 2 selectively, after each line indentation arrRows = Split (ReadRangeSQL, vbCrLf) For i = LBound (arrRows) For UBound (arrRows) If Len (arrRows (i))> 16 Then If InStr (12, arrRows ( i), SPACE4)> 0 Then ArrRows (i) = Left $ (arrRows (i), 12) and Replace (Right $ (arrRows (i), Len (arrRows (i)) - 12), SPACE4, SPACE and SPACE ) End If End If Next I ReadRangeSQL = Join (arrRows, vbCrLf) Erase arrRows
End if
If Len (ReadRangeSQL)> MAX_LEN Then
"Reduce the size of the tab to 2 indiscriminately. This will make your SQL illegible:
Do While InStr (1, ReadRangeSQL, SPACE4, vbBinaryCompare)> 0 ReadRangeSQL = Replace (ReadRangeSQL, SPACE4, SPACE, and SPACE) Loop
End if
Final function
Open Sub RangeToFile (ByRef strRange As String) 'Output the range to the csv file in the temporary folder created by the XLConnection function' strRange indicates the range in the current workbook using the 'table' naming conventions for Excel OLEDB database drivers: http: // www .connectionstrings.com / excel # 20
"The first row of the range is considered a set of column names.
On error Continue on
Dim objFSO As Scripting.FileSystemObject
Dim rng As Excel.Range Dim strFile As String Dim arrData as a variant of Dim iRow As Long Dim jCol As Long Dim strData As String Dim strLine As String
strRange = Replace (strRange, "[", "") strRange = Replace (strRange, "]", "")
If Right (strRange, 1) = "$" Then strRange = Replace (strRange, "$", "") Set rng = ThisWorkbook.Worksheets (strRange) .UsedRange still strRange = Replace (strRange, "$", "") Set rng = Range (strRange)
If rng means nothing Set rng = ThisWorkbook.Worksheets (strRange) .UsedRange End If
End if
If rng means nothing Exit Sub End If
Set objFSO = New script .FileSystemObject strFile = m_strTempFolder and strRange and ".csv"
If objFSO.FileExists (strFile) Then objFSO.DeleteFile strFile, True End If
If objFSO.FileExists (strFile) Then Exit Sub End If
arrData = rng.Value2
With objFSO.OpenTextFile (strFile, ForWriting, True)
'String header: strLine = "strData =" "iRow = LBound (arrData, 1) For jCol = LBound (arrData, 2) To UBound (arrData, 2) strData = arrData (iRow, jCol) strData = Replace (strData, Chr (34), Chr (39)) strData = Replace (strData, Chr (10), "") strData = Replace (strData, Chr (13), "") strData = strData and "," strLine = strLine and strData Next jCol
strLine = Left (strLine, Len (strLine) - 1) 'Trailing comma for comma
If Len (Replace (Replace (strLine, Chr (34), ""), ",", ""))> 0 Then .WriteLine strLine End If
The rest of the data For iRow = LBound (arrData, 1) + 1 To UBound (arrData, 1)
strLine = "" strData = ""
For jCol = LBound (arrData, 2) To UBound (arrData, 2) If IsError (arrData (iRow, jCol)) Then strData = "#ERROR" is still strData = arrData (iRow, jCol) strData = Replace (strData, Chr ( 34), Chr (39)) strData = Replace (strData, Chr (10), "") strData = Replace (strData, Chr (13), "") strData = Replace (strData, Chr (9), "") strData = Trim (strData) End If strData = Chr (34) and strData and Chr (34) and "," 'Quotes to force all values to text strLine = strLine and strData Next jCol
strLine = Left (strLine, Len (strLine) - 1) 'Trailing comma for comma
If Len (Replace (Replace (strLine, Chr (34), ""), ",", ""))> 0 Then .WriteLine strLine End If
Next iRow
.Close End With 'textstream object from objFSO.OpenTextFile
Set objFSO = Nothing Erase arrData Set rng = Nothing
End sub
And finally, writing a set of records to a range - the code would be trivial if not for all the errors you have to deal with:
Public Sub RecordsetToRange (rngTarget As Excel.Range, objRecordset As ADODB.Recordset, optional field list as an option, optional ShowFieldNames as Boolean = False, optional orientation in Excel.XlRowCol = xlRows format)
"Write ADO recordset to Excel range in one" hit "on a sheet" The call function is responsible for setting the record pointer (should not be EOF!)
'The target range is automatically resized to the array, and the upper left cell is used as the starting point.
On error Continue on
Dim OutputArray as an option
Dim I'm As Integer
Dim iCol As Integer
Dim iRow As Integer
Dim varField as an option
If objRecordset Doesn't Mean Exit Sub
End if
If objRecordset.State <> 1 Then Exit Sub
End if
If objRecordset.BOF AND objRecordset.EOF Then Exit Sub
End if
If Orientation = xlColumns Then If IsEmpty (FieldList) or IsMissing (FieldList) Then OutputArray = objRecordset.GetRows else OutputArray = objRecordset.GetRows (Fields: = FieldList) End If
else If IsEmpty (FieldList) or IsMissing (FieldList) Then OutputArray = ArrayTranspose (objRecordset.GetRows) else OutputArray = ArrayTranspose (objRecordset.GetRows (Fields: = FieldList)) End If
End if
ArrayToRange rngTarget, OutputArray
If ShowFieldNames Then
If Orientation = xlColumns Then
ReDim OutputArray (LBound (OutputArray, 1) To UBound (OutputArray, 1), 1 to 1)
iRow = LBound (OutputArray, 1)
If IsEmpty (FieldList) or IsMissing (FieldList) Then For i = 0 For objRecordset.Fields.Count - 1 If i> UBound (OutputArray, 1) Then Exit for End If OutputArray (iRow + i, 1) = objRecordset.Fields ( i) .Name Next I still If InStr (TypeName (FieldList), "(") <1 Then FieldList = Array (FieldList) End If i = 0 For each varField In FieldList OutputArray (iRow + i, 1) = CStr (varField ) i = i = 1 next End If
ArrayToRange rngTarget.Cells (1, 0), OutputArray
Else
ReDim OutputArray (1 to 1, LBound (OutputArray, 2) to UBound (OutputArray, 2))
iCol = LBound (OutputArray, 2)
If IsEmpty (FieldList) or IsMissing (FieldList) Then For i = 0 For objRecordset.Fields.Count - 1 If i> UBound (OutputArray, 2) Then Exit for Finish If OutputArray (1, iCol + i) = objRecordset.Fields ( i) .Name Next I still If InStr (TypeName (FieldList), "(") <1 Then FieldList = Array (FieldList) End If i = 0 For each varField In FieldList OutputArray (1, iCol + i) = CStr (varField ) i = i = 1 next End If
ArrayToRange rngTarget.Cells (0, 1), OutputArray
End if
End If 'ShowFieldNames
Erase OutputArray
End sub
Public function ArrayTranspose (InputArray as an option) as an option
'Move InputArray.
'Returns an InputArray unchanged if it is not a 2-dimensional variant (x, y)
Dim iRow As Long
Dim iCol As Long
Dim iRowCount how long
Dim iColCount how long
Dim boolNoRows As Boolean
Dim BoolNoCols As Boolean
Dim OutputArray as an option
If IsEmpty (InputArray) Then ArrayTranspose = InputArray Output Function
End if
If InStr (1, TypeName (InputArray), "(") <1 Then ArrayTranspose = InputArray Exit Function
End if
"Make sure we can read the dimensions of the array:
On error Continue on
Err.Clear iRowCount = 0 iRowCount = UBound (InputArray, 1) If Err.Number <> 0 Then boolNoRows = True End If Err.Clear
Err.Clear iColCount = 0 iColCount = UBound (InputArray, 2) If Err.Number <> 0 Then BoolNoCols = True End If Err.Clear
If boolNoRows Then
'All arrays have a specific Ubound (MyArray, 1)! "These measurement options cannot be determined. OutputArray = InputArray
ElseIf BoolNoCols Then
“This is a vector. Strictly speaking, a vector cannot be“ transposed ”, since“ calling the ordinal ”row“ or ”column“ is arbitrary or meaningless. "But ... By convention, Excel users consider the vector as an array of 1 to n 'rows and 1 column. Thus, we will" transfer "it to a variant (from 1 to 1, from 1 to n)
ReDim OutputArray (1 to 1, LBound (InputArray, 1) to UBound (InputArray, 1))
For iRow = LBound (InputArray, 1) for UBound (InputArray, 1)
OutputArray (1, iRow) = InputArray (iRow)
Next iRow
Else
ReDim OutputArray (LBound (InputArray, 2) To UBound (InputArray, 2), LBound (InputArray, 1) for UBound (InputArray, 1))
If IsEmpty (OutputArray) Then ArrayTranspose = InputArray Output Function End If
If InStr (1, TypeName (OutputArray), "(") <1 Then ArrayTranspose = InputArray Output Function End If
For iRow = LBound (InputArray, 1) for UBound (InputArray, 1) For iCol = LBound (InputArray, 2) for UBound (InputArray, 2) OutputArray (iCol, iRow) = InputArray (iRow, iCol) Next iCol Next iRow
End if
ExitFunction:
ArrayTranspose = OutputArray Erase OutputArray
Final function
Let me know how you are doing. As always, watch out for formatting crashes: I never had the code <code> tags to work on this site and <PRE> is not always respected by text fields when the preformatted text contains quotation marks and HTML objects.
Postscript: running SQL in Excel table objects
For completeness, here is the code for reading in the form of a table of tables with an SQL table with an SQL function that handles all hacking of a text file in the background.
I am sending it now, some time after my initial answer, because everyone uses a rich table object for table data in Excel:
"Run the JOIN query in your tables and write the field names and data in Sheet1:
... And a complete list (give or take a couple of functions in the previous code dump):
Public function RunSQL (SQL As String, TargetRange as Excel.Range, Optional DataSetName As String)
"Run SQL with the table files in the local ExcelSQL folder and write the results in the target range
"SQL can be read from ranges using the ReadRangeSQL function
Dim rst As ADODB.Recordset
still RecordsetToRange rst, TargetRange, True Set rst = Nothing
End if
0, then SetSchema
1 i = (i + 1) Mod 3 Application.StatusBar = "Waiting for data" and String (i, ".") Application.Wait Now + (0.25 / 24/3600) Loop
Finish with
ERR_ADO:
strMsg = vbCrLf and vbCrLf and "If this is a file error, someone opened one of the source data files: try again in a few minutes." and vbCrLf and vbCrLf and "Otherwise, pay attention to this error message and contact the developer, or" and SUPPORT "and". ". If Verbose Then MsgBox is" Error & H "and Hex (Err.Number) and": "and Err.Description and strMsg, vbCritical + vbMsgBoxHelpButton," Data search error: ", Err.HelpFile, Err.HelpContext End If Summary ExitSub
Exit function
Dim strTempFolder
If m_objConnText doesn't mean anything
Set m_objConnText = New ADODB.Connection
strTempFolder = TempSQLFolder ', this will check if the folder allows SQL READ operations
Application.DisplayAlerts = False
'MS-Access ACE OLEDB Provider m_strConnText = "Provider = Microsoft.ACE.OLEDB.12.0; Data Source =" and Chr (34) and strTempFolder and Chr (34) and "; Persist Security Info = True;" m_strConnText = m_strConnText and "Extended Properties =" and Chr (34) and "text; CharacterSet = UNICODE; HDR = Yes; HDR = Yes; IMEX = 1; MaxScanRows = 1" and Chr (34) and ";"
End if
If Not m_objConnText Means Nothing
With m_objConnText
If .State = adStateClosed Then
Application.StatusBar = "Connecting to local Excel tables" .CursorLocation = adUseClient .CommandTimeout = 90 .ConnectionString = m_strConnText .Mode = adModeRead .Open
End if
Finish with
If m_objConnText.State = adStateClosed Then Set m_objConnText = Nothing End If
End if
Set connText = m_objConnText
ExitSub: Application.StatusBar = False Exit Property
ErrSub: MsgBox "Error connecting to local Excel data. Please contact" and SUPPORT and "." , vbCritical + vbApplicationModal, "Error connecting to database!", 10 Summary ErrEnd 'Resume ExitSub
ErrEnd: Final terminal error. Halt.
Final property
Open Sub CloseConnections ()
On error Continue on
Set m_objConnText = Nothing
End sub
Public function TempSQLFolder () As String
Application. Sustainable False
'Location of temporary table files used by SQL text data functions
'Also launches a background process to clear files within 7 days
"The best location is a named subfolder in the temporary user folder.
'local user folder' temp 'can be found on all windows systems using
"GetObject (" Scripting.FileSystemObject "). GetSpecialFolder (2) .ShortPath
'and usually will be C: \ Users [Username] \ AppData \ Local \ Temp
'Dependencies:
'FSO object property (returns Scripting.FilesystemObject)
"
Dim strCMD As String
Dim strMsg As String
Dim strNamedFolder As String
Static strTempFolder As String 'Cache it
Dim iRetry As Integer
Dim I'm As Long
"If we already found a convenient temp folder, use a static value
'without requesting the file system and checking write permissions again:
If strTempFolder <> "" Then TempSQLFolder = strTempFolder Exit Function
End if
On error Continue on
strTempFolder = GetObject ("Scripting.FileSystemObject"). GetSpecialFolder (2) .ShortPath
If Right (strTempFolder, 1) <> "\" Then strTempFolder = strTempFolder and "\" End If
strTempFolder = strTempFolder and "XLSQL"
If not FSO.FolderExists (strTempFolder) Then FSO.CreateFolder strTempFolder End If
i = 1 Before FSO.FolderExists (strTempFolder) Or i> 6 Sleep i * 250 Application.StatusBar = "Waiting for SQL cache folder" and String (i Mod 4, ".") Loop
If not FSO.FolderExists (strTempFolder) Then GoTo Retry End If
If Right (strTempFolder, 1) <> "\" Then strTempFolder = strTempFolder and "\" End If
TempSQLFolder = strTempFolder
Application.StatusBar = False
Final function
Public property Get FSO () As Scripting.FileSystemObject '
'Return file system object
On error Continue on
If m_objFSO Means Nothing Set m_objFSO = CreateObject ("Scripting.FileSystemObject") 'New Scripting .FileSystemObject
End if
If m_objFSO Doesn't Mean Anything Shell "Regsvr32.exe / s scrrun.dll", vbHide Set m_objFSO = CreateObject ("Scripting.FileSystemObject")
End if
Set FSO = m_objFSO
Final property
Public Sub SaveTable (optional table name as string = "")
'Export table object to local SQL folder as csv file
'If no name is specified, all tables are exported asynchronously
"This step is necessary to run SQL on tables
Dim wks Like Excel. Grid
Dim oList Like Excel.ListObject
Dim sFile As String
Dim bAsync As Boolean
If TableName = "" Then bAsync = True
still bAsync = False
End if
For each wks in ThisWorkbook.Worksheets For each oList In wks.ListObjects If oList.Name Like TableName Then sFile = oList.Name ArrayToCSV oList.Range.Value2, sFile ,,,, bAsync 'Debug.Print' ["and sFile and" .csv] "End If Next oList
Next wks
Setchema
End sub
Public Sub RemoveTable (optional TableName As String = "*")
On error Continue on
"Clear temporary files" Table "in the local folder of the user's temporary file:
Dim wks Like Excel. Grid
Dim oList Like Excel.ListObject
Dim sFile As String
Dim sFolder As String
sFolder = TempSQLFolder
For each wks in ThisWorkbook.Worksheets For each oList In wks.ListObjects
If oList.Name Like TableName Then sFile = oList.Name and ".csv" If Len (Dir (sFile))> 0 Then Shell "CMD / c DEL" and Chr (34) and sFolder and sFile and Chr (34), asynchronous removal of vbHide End If End If
Next oList
Next wks
End sub
Share and enjoy: this is a terrible hack, but it gives you a stable SQL platform.
And we still do not have a stable "native" platform for SQL in Excel: the data provider Microsoft.ACE.OLEDB.14.0 Excel still has the same memory leaks as Microsoft.Jet.OLEDB.4.0 and Excel ODBC which preceded this twenty years ago.