Thursday 18 September 2014

A Horrible Hack: Complex SQL Queries on Excel Data


A Cautionary Tale of things that no developer should ever see or do, with diversions and digressions into failures of business logic, workarounds and worse-arounds, budget fairies, business analysts, and scrofulous pilgrims seeking miraculous healing in the elevator lobby.




From time to time it necessary to perform a Horrible Hack. A hack that might have tolerable snippets of code, or even pretty nifty ones; but it's a Horrible Hack if the whole thing, taken as a whole, ought to be buried in a hole - and this post show you the code for one of them.

The task is deceptively simple: perform SQL queries on data sets that happens to be in Excel. Because vlookup can only do so much, and Pivot tables aren't flexible enough, and WHY AREN'T YOU DOING THIS IN A PROPER DATABASE INSTEAD OF KLUDGING?

Well, the answer to that is: "It's a prototype, and it's on the stack for the database developers to get it done properly". Except that it's still running in Excel, a year or so later, and the database guys aren't going to touch it. Ever. Because the SQL is too complex for them, or it wasn't invented here, or maybe you don't have the staffing budget for human sacrifice or whatever propitiates the wrath of database administrators.

Other reasons: the data for our report exists in multiple systems, not all of them expose a SQL interface, and the *only* export format that they have in common in they can spit out .xls files. And some of the config data (exception lists) only exists in an Excel sheet on a Sharepoint server. Yes, we'd like that to live in a proper table in a named application with a relational database: and no, nobody's going to build it. Ever. Not 'til Hell freezes over and the magic budget fairy brings you a dedicated infrastructure spend and three business analysts bearing gold, detailed system specifications, and signoff from managers so senior that queues of pilgrims wait outside the executive elevator lobby, hoping for the chance to touch the hem of their suits and cure themselves of scrofula.

And this is where Horrible Hacks come from, on the user side: business requirements that emerge from a need to work around blockages and other anomalies in the business processes we serve in our software.

But to be truly horrible, a Horrible Hack needs an additional layer of complexity arising from the need to work around a fundamental failure in the technical platform. And yes, we have *just* the thing: Microsoft's SQL drivers for Excel are unstable. You can't just connect to an Excel workbook - closed or open - with an OLEDB session using the publicly-available Excel driver; nor can you do so with ODBC ISAM drivers - they all have memory leaks, and they will all crash the host application if you run them often enough. So Excel data isn't directly available to complex SQL.

So... How bad can it get?

Well, we start by grabbing the data from closed workbooks using SQL sent to the Excel OLEDB driver. We can *just* get away with it by closing the connections immediately. If I was paranoid, I'd run this in 'shelled' separate sessions of Excel.exe - but that really is too much work for an app that's going to be replaced by the grown-ups in a proper Dev team, right?

We save that data as text files in a temporary folder.

And read those files, just as if they were tables in a database, using SQL and the Microsoft Jet Text OLEDB driver.

Yes, you heard that correctly: we're using JET SQL. It's a peculiar dialect of SQL... And if you want to get clever with the data-grabbing phase, and filter the data you grab from the source range, you'll need to know the arcane conventions for naming the 'table' in your query with a '$' depending on whether it's a named range or a sheet, or a range address. Oh, and bracketing it. Mustn't forget bracketing.

But once we get beyond that, and you're just querying the 'tables' you've created in that temp folder, it's actually pretty straightforward. Unions, joins, aliasing tables into subqueries, conditional logic (IF statements, JET SQL doesn't support CASE): the whole of SQL is there for you.

Excel is actually a pretty good SQL editor - if you have a well-written text-grabber to read the range you're writing SQL in - because moving blocks of text around and marking-up with background shading is really, really easy. And the smart kids will have a range marked up as 'Test SQL' with a 'GetRecordset' function behind the 'Test It!' button that returns the full error strings from the database engine, which includes the syntax errors and line numbers.

Oh, and you can use Excel Formulas to feed in parameters, especially start and end dates: my advice is 'Be sparing with that', but it's just too damned convenient. I would suggest formatting any text that does that in red, just so that you know. I would also recommend casting your dates to doubles, and be *very* defensive about nulls and type errors.

Here's what I mean by 'defensive': a sample of a straightforward JET SQL query with embedded dates from Excel formulae...

SELECT  [Workbook Group],  IIF( [Region] IS NULL, '', [Region]) AS [Region],  IIF([File ID] IS NULL, 0, CDBL([File ID])) AS [File ID],  [File Name],  IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint]))           ) AS [EventTime],  IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) + (5/24)) AS [EventTimePlusNA],  IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) + (4/24)) AS [EventTimePlusNA1],  IIF([Timepoint] IS NULL, NULL, (CDATE([Timepoint])) - (7/24)) AS [EventTimeMinusAsia],  [Reason],  [Owner],  CDBL(CDATE([Expiry])) AS [Expiry], [Standard Reason] FROM   ( SELECT *  FROM  [Signoff Exceptions$]   WHERE [File ID] IS NOT NULL   AND [Expiry] IS NOT NULL   AND [Reason] IS NOT NULL   AND [Owner] IS NOT NULL   AND (    (ISDATE([Timepoint])  AND   AND   AND   AND  AND NOT ([Timepoint] IS NULL OR [Timepoint] = 0 )) OR ([Standard Reason] LIKE 'No Reportable%' AND ([Timepoint] IS NULL OR [Timepoint] = 0 OR [Timepoint] LIKE 'ALL'  OR [Timepoint] ='' ))   ) ) AS tFile WHERE ( [TimePoint] IS NULL  OR IIF(ISDATE([TimePoint]),    ( CDBL(CDATE([Timepoint]))  >= CDBL(CDATE(41595))    AND CDBL(CDATE([Timepoint]))  <= CDBL(CDATE(41622))   ),  FALSE     ) ) AND (  IIF(ISDATE([Expiry]), CDBL(CDATE([Expiry])) >= CDBL(CDATE(41900)), TRUE)  ) AND [File ID] IS NOT NULL


Alert readers will spot the '$' dollar sign on the table name. Yes, this is a SQL query sent to the data grabber, filtering the data before we save it to a .csv text file in the 'database' folder with the other 'tables'. We could've just sent the range name 'Signoff Exceptions$' directly to the data grabber:
    arrData = GetDataFromClosedWorkbook(strFilePath, 'Signoff Exceptions$', "", ReadHeaders:=True)

As opposed to:
    arrData = GetDataFromClosedWorkbook(strFilePath, 'Signoff Exceptions$', "", ReadHeaders:=True)


The real SQL - actually querying the tables we've created - can be as simple as you like:

SELECT      IIF(tP.[File ID] IS NULL, '(Unknown)', tP.[Workbook Group]) AS [Workbook Group],      IIF(tP.[File ID] IS NULL, '*WARNING* FILE ID ' & tX.[File ID] & ' NOT FOUND ', '') &  tX.[File Name] AS [File Name],      tX.[File ID],      tX.[Region],      IIF(tX.[EventTime] IS NULL,  'ALL',              CDBL( CDATE(tX.[EventTime]) )        ) AS [Event Time],      tX.[Reason],      tX.[Owner],      IIF(tX.[Expiry] IS NULL, NULL, CDBL(CDATE(tX.[Expiry]))) AS [Exemption Expiry],      [Standard Reason] FROM        (SELECT * FROM [tblExemptions.csv] WHERE  [File ID] <> 'Type=Text' AND [File ID] IS NOT NULL  ) AS tX      LEFT JOIN  (SELECT * FROM [tblPatterns.csv] WHERE  [File ID] <> 'Type=Text' AND [File ID] IS NOT NULL  ) AS tP            ON tX.[File ID] = tP.[File ID] WHERE     tX.[Standard Reason] NOT LIKE 'No Reportable%' ORDER BY     tP.[Workbook Group],      tX.[File Name],      IIF(tX.[Expiry] IS NULL, NULL, CDATE(tX.[Expiry])) 


The SQL can also be as complicated as you like, and that's what this is all about: we're doing data queries in SQL because the logic we need to implement is far, far too complex for the user tools provided in a desktop application. Excel's good, and pivoting is remarkably good, but it's good for tasks within the reach of people without formal training in structured data.

Which brings us to the next part: presentation and the User Experience...

One thing you won't see here, because I'm only posting the code, is Rule 1 of Horrible Hacks: Horrible under the surface, but a clean, crisp, beautiful interface. The uglier your plumbing, the prettier the faucets, the basin and the bidet... And *this* one went out with the interface design equivalent of gold-plated crystal faucets and a four-piece chamber orchestra playing for you as the Personal Assistant checks the loofah for *exactly* the right degree of scratchiness while running the bath to the perfect temperature.

OK. Lets get started.There's a big red button and all it does is call 'Grab the data' and 'Run the reports':

Public Sub RunReports()     FetchSourceData     SignoffTimestamp     ReportAcceptances     ReportExemptions     ReportSignoffsALL     ReportSummary     ThisWorkbook.Names("Report_TimezoneDescription").RefersToRange.Value = "All timestamps are " & TimeZone     ThisWorkbook.Names("Datestamp_LastRun").RefersToRange.Value = Now()     Application.Calculate End Sub


Not very informative... But the point is, we try and keep individual functions simple. And we segregate our code: this is from the application's custom module - the reports are in here, as is FetchSourceData (the 'grabber) because they're all custom code for this specific app.

There's a separate module called 'basExcelSQL', and that contains all the generic SQL-reading and ADODB-connecting code that gets reused whenever I have to try this stunt again. And yes, I do, and did.

SO lets look at the 'report' functions, using the Exemptions report as a sample:

Public Sub ReportExemptions() Application.StatusBar = "Exemptions report..." Dim SQL As String Dim rst As ADODB.Recordset Dim rng As Excel.Range Dim j As Integer Dim strSource As String Set rng = ThisWorkbook.Names("Report_Exempted").RefersToRange SQL = ReadRangeSQL(ThisWorkbook.Names("SQL_Exemption_List").RefersToRange) rng.ClearContents Set rst = FetchRecordset(SQL) If rst Is Nothing Then Exit Sub End If If rst.State <> 1 Then Exit Sub End If ' Write out the column headings For j = 0 To rst.Fields.Count - 1 rng.Cells(1, j + 1) = rst.Fields(j).Name Next j If Not (rst.EOF And rst.BOF) Then ArrayToRange rng.Cells(2, 1), ArrayTranspose(rst.GetRows) rng.AutoFilter End If rst.Close rst.ActiveConnection.Close Set rst = Nothing Application.StatusBar = False End Sub


Yes, I could parameterise it: and no, I didn't. All of the individual report functions look like this, because they all ended up getting customised - it's what this module's for, custom code - and this one got an extra function to diplay a timestamp and time-of-file in the report header, with a checked and updated hyperlink to the source file on the SharePoint folder. Other reports got custom formatting, special headers, and so on.

We'll be looking at ReadRangeSQL and FetchRecordset later, with the rest of the 'basExcelSQL' module; the point here is that we have clean code on top of the Horrible Hack, and less-confident developers can easily reuse your code.

So what does 'FetchSourceData' do? Well, it reads a table - not in SQL this time, we've got to start somewhere, so this is an Excel Range on a sheet called 'Settings' - listing the folders and the files...

...EXCEPT that we're reading files dumped in folders by server-based applications, with date strings in the names. So we can look for a literal file name, or look for a wildcard search string, and pick out the most recently-saved file.

Public Sub FetchSourceData() Application.StatusBar = "Fetching source data..." ' Read each file in the 'TableNames' range into a local table ' In more detail: ' 1: If a pattern (wildcard '*') is used, use the most recent matching file ' 2: Write the data to a properly formatted csv file in a local temp folder ' 3: These named csv files are visible to the Microsoft Text ISAM as tables ' in a 'database' (the folder containing them) which supports MS JET SQL Dim strSourceFolder As String Dim strSourceFile   As String Dim strTable As String Dim strRange As String Dim dblLastImport   As Double Dim strFieldNames   As String Dim arrTables    As Variant Dim iRow As Integer Dim varData  As Variant Dim strFilePath  As String Dim dblFileDate  As Double Dim maxFileDate  As Double Dim strFoundFile As String Dim strUseFile   As String SheetSettings.Calculate strSourceFolder = ThisWorkbook.Names("SourceFolder").RefersToRange.Value2 If InStr(1, strSourceFolder, "//") > 0 Then If Right(strSourceFolder, 1) <> "/" Then strSourceFolder = strSourceFolder & "/" End If Else If Right(strSourceFolder, 1) <> "\" Then strSourceFolder = strSourceFolder & "\" End If End If ' Parse out web folder paths If Left(strSourceFolder, 5) = "http:" Then strSourceFolder = Right(strSourceFolder, Len(strSourceFolder) - 5) strSourceFolder = Replace(strSourceFolder, "%20", " ") strSourceFolder = Replace(strSourceFolder, "%160", " ") strSourceFolder = Replace(strSourceFolder, "/", "\") End If Application.StatusBar = "Fetching source data" ' Column 1: strTable  = arrTables(iRow, 1)  - the table name (csv filename) in the 'database' temp folder ' Column 2: strRange  = arrTables(iRow, 2)  - The range address, or a SQL string reading and filtering the range ' Column 3: strSource = arrTables(iRow, 3)  - The file ( a literal name or a wildcard search term ) ' The other columns are datestamps and status / error information arrTables = ThisWorkbook.Names("TableNames").RefersToRange.Value2 For iRow = LBound(arrTables, 1) + 1 To UBound(arrTables, 1) Application.StatusBar = "Fetching source data" & String((iRow Mod 3) + 1, ".") strTable = "" strTable = arrTables(iRow, 1) If strTable <> "" Then If IsError(arrTables(iRow, 2)) Then arrTables(iRow, 2) = "#ERROR" End If strRange = arrTables(iRow, 2) strSourceFile = arrTables(iRow, 3) If IsDate(arrTables(iRow, 4)) Then dblLastImport = arrTables(iRow, 4) Else dblLastImport = 0 End If strFilePath = strSourceFolder & strSourceFile If InStr(strSourceFile, "*") Then   ' Identify the most recent file matching the pattern given in the TableNames list maxFileDate = 0 strUseFile = "" strFoundFile = "" On Error GoTo ErrFolder strFoundFile = Dir(strSourceFolder & strSourceFile) On Error GoTo ErrSkipFile Do While Len(strFoundFile) > 0 dblFileDate = 0 dblFileDate = VBA.FileSystem.FileDateTime(strSourceFolder & strFoundFile) If dblFileDate > maxFileDate Then strUseFile = strFoundFile maxFileDate = dblFileDate End If strFoundFile = Dir Loop If Len(strUseFile) > 0 Then strFilePath = strSourceFolder & strUseFile ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 5) = strUseFile End If End If On Error GoTo ErrFile If Len(Dir(strFilePath)) = 0 Then If Len(Dir(Folder(strSourceFolder), vbDirectory)) = 0 Then Err.Raise -559038737, APP_NAME & ":FetchSourceData", "The Signoff Progress Report cannot be run because " & APP_NAME & " cannot find the data folder: " & vbCrLf & vbCrLf & "'" & Folder(strSourceFolder) & "'" & vbCrLf & vbCrLf & "Please use Windows Explorer to check that the folder exists, and check that you have permission to open files in it." End If Err.Raise -559038737, APP_NAME & ":FetchSourceData", "The Signoff Progress Report cannot be run because there is no file matching '" & strSourceFile & "' in this location: " & vbCrLf & vbCrLf & strFilePath & vbCrLf & vbCrLf & "Please open the folder and make sure that the source files for the report are in place." End If On Error GoTo ErrSub ' Record the datestamp of the file we've selected for loading ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 6) = VBA.FileSystem.FileDateTime(strFilePath) strFieldNames = "" ' read the data from the file varData = GetDataFromClosedWorkbook(strFilePath, strRange, strFieldNames, True) If IsEmpty(varData) Then ArrayToFile varData, strTable, True, strFieldNames ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 4) = "#NO DATA RETURNED BY THE QUERY" ElseIf IsArray(varData) Then ' write the data to a properly formatted csv file in a local temp folder ArrayToFile varData, strTable, True, strFieldNames ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 4) = Now() Erase varData varData = Empty Else ThisWorkbook.Names("TableNames").RefersToRange.Cells(iRow, 4) = varData varData = Empty End If 'IsEmpty(varData) Then End If ' strTable <> "" Next iRow Erase arrTables ExitSub: Application.StatusBar = False Exit Sub ErrSub: Select Case MsgBox(Err.Description, vbCritical + vbAbortRetryIgnore + vbMsgBoxHelpButton, APP_NAME & ": Error fetching source data", Err.HelpFile, Err.HelpContext) Case vbRetry Resume Case vbIgnore Resume Next Case vbAbort End Case Else ' undefined behaviour from 'Escape' End End Select Resume ExitSub ErrFile: MsgBox Err.Description, vbApplicationModal, "Signoff Progress Report: missing data file" 'This error is fatal - bad file! - and we will halt execution. End ErrFolder: MsgBox "Cannot retrieve file data from the following folder: " & vbCrLf & vbCrLf & strSourceFolder & vbCrLf & vbCrLf & "Windows returned the following error: ERROR " & Err.Number & ": " & Err.Description & vbCrLf & vbCrLf & "Check the folder in Windows Explorer, as the problem may be your access privileges.", vbCritical + vbMsgBoxHelpButton, APP_NAME & ": inaccessible data folder", Err.HelpFile, Err.HelpContext 'This error is fatal - bad data folder! - and we will halt execution. End ErrSkipFile: ' called from resilient code - we're scanning files in a folder, if it's unusable we'll just try the next file Resume Next End Sub Public Function FilePath(strSharePointPath As String) As String Application.Volatile False ' Translate sharepoint paths into their underlying filesystem addresses FilePath = strSharePointPath If Left(FilePath, 5) = "http:" Then FilePath = Right(FilePath, Len(FilePath) - 5) FilePath = Replace(FilePath, "%20", " ") FilePath = Replace(FilePath, "%160", " ") FilePath = Replace(FilePath, "/", "\") End If End Function


Really, it's just a wrapper feeding parameters into GetDataFromClosedWorkbook, which reads data directly from Excel ranges, and for the ArrayToFile function which writes the extracted data into our 'table' files.

WHich is to say: there is one complicated operation in there - reading and checking filenames out of a table - and the other operations are in clearly-named functions. Indirection, we call it.

And so, without further ado (or ADODB), we reveal the code that does the heavy lifting, basExcelSQL:

Option Explicit Option Private Module ' ADODB data retrieval functions to support SQL queries against ' Excel data in the current workbook, and in closed workbooks ' Online reference for connection strings: ' http://www.connectionstrings.com/oracle#p15 ' Online reference for ADO objects & properties: ' http://msdn.microsoft.com/en-us/library/ms678086(v=VS.85).aspx Private m_objFSO As Object ' Scripting.FileSystemObject Private m_strTempFolder As String Private m_objConnText   As ADODB.Connection Private m_strConnText As String Private Property Get objFSO() As Object ' Return a File System Object On Error Resume Next If m_objFSO Is Nothing Then Set m_objFSO = CreateObject("Scripting.FileSystemObject") ' New Scripting.FileSystemObject End If If m_objFSO Is Nothing Then Shell "Regsvr32.exe /s scrrun.dll", vbHide Set m_objFSO = CreateObject("Scripting.FileSystemObject") End If Set objFSO = m_objFSO End Property Private Property Get TempSQLFolder() As String m_strTempFolder = objFSO.GetSpecialFolder(2).ShortPath  ' Scripting.TemporaryFolder If Right(m_strTempFolder, 1) <> "\" Then m_strTempFolder = m_strTempFolder & "\" End If m_strTempFolder = m_strTempFolder & "XLSQL" If Not objFSO.FolderExists(m_strTempFolder) Then objFSO.CreateFolder m_strTempFolder End If If Right(m_strTempFolder, 1) <> "\" Then m_strTempFolder = m_strTempFolder & "\" End If TempSQLFolder = m_strTempFolder End Property Private Property Get connText() As ADODB.Connection On Error Resume Next ' The Excel database drivers have problems when multiple instances of the Excel application ' are running, so we use a text driver to read csv files in a temporary folder. These files ' are populated from ranges specified for use as tables by the FetchXLRecordSet() function. If objFSO Is Nothing Then Exit Property End If On Error GoTo ErrSub Set m_objConnText = New ADODB.Connection ' Specify and clear a temporary folder: m_strTempFolder = objFSO.GetSpecialFolder(2).ShortPath  ' Scripting.TemporaryFolder If Right(m_strTempFolder, 1) <> "\" Then m_strTempFolder = m_strTempFolder & "\" End If m_strTempFolder = m_strTempFolder & "XLSQL" Application.DisplayAlerts = False If Not objFSO.FolderExists(m_strTempFolder) Then objFSO.CreateFolder m_strTempFolder End If If Right(m_strTempFolder, 1) <> "\" Then m_strTempFolder = m_strTempFolder & "\" End If     ' JET OLEDB text driver connection string: '   Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\txtFilesFolder\;Extended Properties="text;HDR=Yes;FMT=Delimited;MaxScanRows=;IMEX=1;"; ' ODBC text driver connection string: '   Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=c:\txtFilesFolder\;Extensions=asc,csv,tab,txt; m_strConnText = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & m_strTempFolder & ";" m_strConnText = m_strConnText & "Extended Properties=" & Chr(34) & "text;HDR=Yes;IMEX=1;MaxScanRows=0" & Chr(34) & ";"   ' SetTypeGuessRows With m_objConnText .CursorLocation = adUseClient .CommandTimeout = 90 .ConnectionString = m_strConnText .Mode = adModeRead End With If m_objConnText.State = adStateClosed Then Application.StatusBar = "Connecting to the local Excel tables" m_objConnText.Open End If Set connText = m_objConnText ExitSub: Application.StatusBar = False Exit Property ErrSub: MsgBox "Error connecting to the Excel local data. Please contact Application Support.", vbCritical + vbApplicationModal, "Database connection failure!", 10 Resume ErrEnd ' Resume ExitSub ErrEnd: End   ' Terminal error. Halt. End Property Public Sub CloseConnections() On Error Resume Next Set m_objConnText = Nothing End Sub Public Function FetchRecordset(SQL As String) As ADODB.Recordset ' Fetch records from the saved text files extracted by reading all those Excel ranges ' It is assumed that you know the arcane SQL conventions for the Microsoft TEXT driver Dim rst As ADODB.Recordset On Error Resume Next Dim i As Integer Dim iFrom As Integer Set FetchRecordset = New ADODB.Recordset With FetchRecordset .CacheSize = 8 Set .ActiveConnection = connText On Error GoTo ERR_ADO .Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch i = 0 Do While .State > 1 i = (i + 1) Mod 3 Application.StatusBar = "Connecting to the database" & String(i, ".") Application.Wait Now + (0.25 / 24 / 3600) Loop End With Application.StatusBar = False ExitSub: Exit Function ERR_ADO: Dim strMsg strMsg = vbCrLf & vbCrLf & "If this is a 'file' error, someone's got one of the source data files open: try again in a few minutes." & vbCrLf & vbCrLf & "Otherwise, please make a note of this error message and contact the Desktop Support team." MsgBox "Error &H" & Hex(Err.Number) & ": " & Err.Description & strMsg, vbCritical + vbMsgBoxHelpButton, "Data retrieval error:", Err.HelpFile, Err.HelpContext Resume ExitSub End Function Public Function FetchXLRecordSet(SQL As String, ParamArray TableNames()) As ADODB.Recordset ' This allows you to retrieve data from Excel ranges using SQL ' ...Using Range names directly, by copying the range data to .csv files in a temp ' folder... ' As the Excel OLEDB and ODBC database drivers have problems with multiple running ' instances of Excel, this function has been implemented to use a text driver. You ' need to pass additional parameters specifying each range you're using as a table ' so that the these ranges can be saved as csv files in the SQLXL temporary folder ' Note that your query must still use the naming conventions required by the Excel ' database drivers: http://www.connectionstrings.com/excel#20 ' Sample usage: ' '   Set rst = FetchXLRecordSet(SQL, "TableAccountLookup", "TableCashMap") ' ' Where 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) As 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 On Error Resume Next Dim i As Integer Dim iFrom As Integer Dim strRange As String Set FetchXLRecordSet = New ADODB.Recordset With FetchXLRecordSet .CacheSize = 8 Set .ActiveConnection = connText ' This recreates the database connection, and clears ' the temporary folder containing our csv data files iFrom = InStr(8, SQL, "From", vbTextCompare) + 4 For i = LBound(TableNames) To UBound(TableNames) strRange = "" strRange = TableNames(i) RangeToFile strRange SQL = Left(SQL, iFrom) & Replace(SQL, strRange, strRange & ".csv", iFrom + 1, 1) Next i SQL = Replace(SQL, ".csv.csv", ".csv") .Open SQL, , adOpenStatic, , adCmdText + adAsyncFetch i = 0 Do While .State > 1 i = (i + 1) Mod 3 Application.StatusBar = "Connecting to the database" & String(i, ".") Application.Wait Now + (0.25 / 24 / 3600) Loop End With Application.StatusBar = False End Function Public Function ReadRangeSQL(SQL_Range As Excel.Range) As String ' Read a range into a string. ' Each row is delimited with a carriage-return and a line break. ' Empty cells are concatenated into the string as 'Tabs' of four spaces. Application.Volatile False Dim i As Integer Dim j As Integer Dim arrRows As Variant Dim strRow As String arrRows = SQL_Range.Value2 If InStr(TypeName(arrRows), "(") Then For i = LBound(arrRows, 1) To UBound(arrRows, 1) strRow = "" For j = LBound(arrRows, 2) To UBound(arrRows, 2) If Trim(arrRows(i, j)) = "" Then arrRows(i, j) = " " End If strRow = strRow & arrRows(i, j) Next j strRow = RTrim(strRow) If strRow <> "" Then ReadRangeSQL = ReadRangeSQL & strRow & vbCrLf End If Next i Erase arrRows Else ReadRangeSQL = CStr(arrRows) End If End Function Public Sub RangeToFile(ByRef strRange As String) ' Output a range to a csv file in a temporary folder created by the connText function ' strRange specifies a range in the current workbook using the 'table' naming conventions ' specified for Excel OLEDB database drivers:   http://www.connectionstrings.com/excel#20 ' Note that the first row of the range is assumed to be a set of column names. On Error Resume Next If objFSO Is Nothing Then Exit Sub End If Dim rng  As Excel.Range Dim strFile As String Dim arrData As Variant 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 Else strRange = Replace(strRange, "$", "") Set rng = Range(strRange) End If If rng Is Nothing Then Exit Sub End If If objFSO Is Nothing Then Exit Sub End If strFile = m_strTempFolder & strRange & ".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, 2, True)  ' ForReading = 1, ForWriting = 2, ForAppending = 8 ' Header row: 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 & "," strLine = strLine & strData Next jCol strLine = Left(strLine, Len(strLine) - 1)   ' Trim trailing comma If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then .writeline strLine End If ' 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" Else strData = arrData(iRow, jCol) strData = Replace(strData, Chr(34), Chr(39)) strData = Replace(strData, Chr(10), " ") ' removing line breaks is not RFC 4180 compliant strData = Replace(strData, Chr(13), " ") ' ...but the Excel driver will break if we don't strData = Replace(strData, Chr(9), " ") strData = Trim(strData) End If strData = Chr(34) & strData & Chr(34) & ","  ' Enclosing by quotes coerces all values to text strLine = strLine & strData Next jCol strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then .writeline strLine End If Next iRow .Close End With ' textstream object from objFSO.OpenTextFile Erase arrData Set rng = Nothing End Sub Public Sub ArrayToFile(ByRef arrData As Variant, ByVal strName As String, Optional bTranspose As Boolean = False, Optional Header As String = "", Optional CoerceText As Boolean = True) ' Output an array to a csv file in a temporary folder created by the connText function ' arrRange is data from a range ' Note that the first row of the array is assumed to be a set of column names. On Error Resume Next Dim iRow As Long Dim jCol As Long Dim strData As String Dim strLine As String Dim strFile As String Dim iOffset As Long Dim arrHeaders  As Variant Dim i    As Long If objFSO Is Nothing Then Exit Sub End If If Right(strName, 1) = "$" Then strName = Left(strName, Len(strName) - 1) End If strFile = TempSQLFolder & strName & ".csv" If objFSO.FileExists(strFile) Then objFSO.DeleteFile strFile, True End If If objFSO.FileExists(strFile) Then Exit Sub End If With objFSO.OpenTextFile(strFile, 2, True)  ' ForReading = 1, ForWriting = 2, ForAppending = 8 ' Header row: strLine = "" strData = "" If Header <> "" Then  .writeline Header  iOffset = 0    If CoerceText Then arrHeaders = Split(Header, ",") For i = LBound(arrHeaders) To UBound(arrHeaders) arrHeaders(i) = Chr(34) & "Type=Text" & Chr(34) Next i For i = 1 To 25 .writeline Join(arrHeaders, ",") Next i Erase arrHeaders  End If   Else iOffset = 1 End If If Not IsEmpty(arrData) Then If bTranspose Then If Header = "" Then iRow = LBound(arrData, 1) For jCol = LBound(arrData, 1) To UBound(arrData, 1) If IsNull(arrData(jCol, iRow)) Then strData = "" ElseIf IsEmpty(arrData(jCol, iRow)) Then strData = "" Else strData = arrData(jCol, iRow) strData = Replace(strData, Chr(34), Chr(39)) strData = Replace(strData, Chr(10), " ") strData = Replace(strData, Chr(13), " ") If IsDate(strData) Then  strData = CDbl(CVDate(strData)) End If End If strData = strData & "," strLine = strLine & strData Next jCol strLine = Left(strLine, Len(strLine) - 1)   ' Trim trailing comma If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then .writeline strLine End If End If ' Rest of the data For iRow = LBound(arrData, 2) + iOffset To UBound(arrData, 2) strLine = "" strData = "" For jCol = LBound(arrData, 1) To UBound(arrData, 1) If IsError(arrData(jCol, iRow)) Then strData = "#ERROR" ElseIf IsNull(arrData(jCol, iRow)) Then strData = "" ElseIf IsEmpty(arrData(jCol, iRow)) Then strData = "" Else strData = arrData(jCol, iRow) strData = Replace(strData, Chr(34), Chr(39)) strData = Replace(strData, Chr(10), " ") ' removing line breaks is not RFC 4180 compliant strData = Replace(strData, Chr(13), " ") ' ...but the Excel driver will break if we don't strData = Replace(strData, Chr(9), " ") If IsDate(strData) Then  strData = CDbl(CVDate(strData)) End If End If strData = Trim(strData) strData = Chr(34) & strData & Chr(34) & ","  ' Enclosing by quotes coerces all values to text strLine = strLine & strData Next jCol strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then .writeline strLine End If Next iRow Else If Header = "" Then iRow = LBound(arrData, 1) For jCol = LBound(arrData, 2) To UBound(arrData, 2) If IsNull(arrData(iRow, jCol)) Then strData = "" ElseIf IsEmpty(arrData(iRow, jCol)) Then strData = "" Else strData = arrData(iRow, jCol) strData = Replace(strData, Chr(34), Chr(39)) strData = Replace(strData, Chr(10), " ") strData = Replace(strData, Chr(13), " ") If IsDate(strData) Then  strData = CDbl(CVDate(strData)) End If End If strData = strData & "," strLine = strLine & strData Next jCol strLine = Left(strLine, Len(strLine) - 1)   ' Trim trailing comma If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then .writeline strLine End If End If ' Rest of the data For iRow = LBound(arrData, 1) + iOffset To UBound(arrData, 1) strLine = "" strData = "" For jCol = LBound(arrData, 2) To UBound(arrData, 2) If IsError(arrData(iRow, jCol)) Then strData = "#ERROR" ElseIf IsNull(arrData(iRow, jCol)) Then strData = "" ElseIf IsEmpty(arrData(iRow, jCol)) Then strData = "" Else strData = arrData(iRow, jCol) strData = Replace(strData, Chr(34), Chr(39)) strData = Replace(strData, Chr(10), " ") ' removing line breaks is not RFC 4180 compliant strData = Replace(strData, Chr(13), " ") ' ...but the Excel driver will break if we don't strData = Replace(strData, Chr(9), " ") strData = Trim(strData) If IsDate(strData) Then  strData = CDbl(CVDate(strData)) End If End If strData = Chr(34) & strData & Chr(34) & ","  ' Enclosing by quotes coerces all values to text strLine = strLine & strData Next jCol strLine = Left(strLine, Len(strLine) - 1) ' Trim trailing comma If Len(Replace(Replace(strLine, Chr(34), ""), ",", "")) > 0 Then .writeline strLine End If Next iRow End If ' bTranspose End If '  If Not IsEmpty(arrData) Then   .Close End With ' textstream object from objFSO.OpenTextFile    End Sub Public Function GetDataFromClosedWorkbook(ByVal SourceFile As String, _   ByVal SourceRange As String, _  Optional ByRef FieldNames As String = "", _  Optional ByVal ReadHeaders As Boolean = False, _  Optional ByVal LocalCopyLifetime As Double = 1#, _  Optional ByVal ForceRecopy As Boolean = False, _  Optional ByVal Asynchronous As Boolean = False) As Variant Application.Volatile False On Error GoTo ErrSub ' Read a Range in a closed workbook (which remains closed throughout the operation - we do not open the file in Excel) ' Returns a TRANSPOSED variant array, in which the first column will be the headers ' If your range is a worksheet, append "$" to the worksheet name ' If you set ReadHeaders=True, the first row of your data will be treated as the field names of a table; this means that you can pass ' a SQL query instead of a range or table name BUT the fierst row of your range will not be included in the returned variant array ' Note that we do not attempt to examine files on network folders: we always copy to a temporary folder '   - However, we'll only overwrite a pre-existing local copy if the pre-existing file is older than LocalCopyLifetime days '   - While the copy-to-local-folder operation in running in asynchronous mode, the function will return #WAITING FOR FILE TRANSFER ' Be warned, the ACE database drivers have serious stability issues and Excel will definitely crash a couple of times ' TO DO: modify parsing of 'Source Sheet' so that we can read a defined name or a range address Dim objConnect  As ADODB.Connection Dim rst  As ADODB.Recordset Dim strConnect  As String Dim i    As Long Dim j    As Long Dim arrData  As Variant Dim TempFile As String Dim strTest  As String Dim SQL  As String Dim iColCount   As Long Dim strPathFull As String Dim strHeaders As String If SourceFile = "" Then Exit Function End If ' Parse out web folder paths If Left(SourceFile, 5) = "http:" Then SourceFile = Right(SourceFile, Len(SourceFile) - 5) SourceFile = Replace(SourceFile, "%20", " ") SourceFile = Replace(SourceFile, "%160", " ") SourceFile = Replace(SourceFile, "/", "\") End If strPathFull = SourceFile If Len(Dir(SourceFile)) = 0 Then GetDataFromClosedWorkbook = "#ERROR Source file not found" Exit Function End If If objFSO Is Nothing Then Exit Function End If TempFile = objFSO.GetSpecialFolder(2).Path & "\" & Filename(SourceFile) If ForceRecopy Then If Len(VBA.FileSystem.Dir(TempFile)) > 0 Then VBA.FileSystem.Kill TempFile End If End If If Not (Left(SourceFile, 3) = "C:\" Or Left(SourceFile, 3) = "D:\") Then   ' Always copy to the local drive    If Len(VBA.FileSystem.Dir(TempFile)) > 0 Then On Error Resume Next If VBA.FileSystem.FileDateTime(TempFile) < VBA.FileSystem.FileDateTime(SourceFile) Then VBA.FileSystem.Kill TempFile ElseIf m_objFSO.GetFile(TempFile).dateLastAccessed < (Now - LocalCopyLifetime) Then VBA.FileSystem.Kill TempFile End If End If If Len(VBA.FileSystem.Dir(TempFile)) = 0 Then If Asynchronous Then Shell "cmd /c COPY " & Chr(34) & SourceFile & Chr(34) & " " & Chr(34) & TempFile & Chr(34), vbHide GetDataFromClosedWorkbook = "#WAITING FOR FILE TRANSFER" Exit Function Else   VBA.FileSystem.FileCopy SourceFile, TempFile     End If Else SourceFile = TempFile End If End If If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then strHeaders = "HDR=Yes" ElseIf ReadHeaders = True Then strHeaders = "HDR=Yes" Else strHeaders = "HDR=No" End If ' " & strHeaders & " If Right(SourceFile, 4) = ".xls" Then '    ' strConnect = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1;DBQ=" & Chr(34) & SourceFile & Chr(34) & ";" & ";Extended Properties=" & Chr(34) & "HDR=No;IMEX=1;MaxScanRows=0" & Chr(34) & ";" strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 8.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"    'strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 8.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"    ElseIf Right(SourceFile, 5) = ".xlsx" Then strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 12.0 Xml;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";" ElseIf Right(SourceFile, 5) = ".xlsm" Then 'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1;DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"   strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 12.0 Macro;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";" ElseIf Right(SourceFile, 5) = ".xlsb" Then    'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1;DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";" ' This ACE driver is unstable on xlsb files... But it's more likely to return a result, if you don't mind crashes: strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";" Else GetDataFromClosedWorkbook = "#ERROR - file format not known" End If On Error GoTo ErrSub 'SetTypeGuessRows Set objConnect = New ADODB.Connection With objConnect .ConnectionTimeout = 60 .CommandTimeout = 90 .Mode = adModeRead .ConnectionString = strConnect .Open End With Set rst = New ADODB.Recordset With rst .CacheSize = 8 .PageSize = 8   If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then SQL = SourceRange Else .MaxRecords = 8192    SQL = "SELECT * FROM [" & SourceRange & "] " End If .Open SQL, objConnect, adOpenStatic, adLockReadOnly End With   On Error Resume Next For i = 0 To rst.Fields.Count - 1 FieldNames = FieldNames & rst.Fields(i).Name & "," Next i FieldNames = Left(FieldNames, Len(FieldNames) - 1) If rst.EOF And rst.BOF Then 'no action Else Err.Clear rst.MoveFirst GetDataFromClosedWorkbook = rst.GetRows If IsEmpty(GetDataFromClosedWorkbook) Then rst.MoveFirst GetDataFromClosedWorkbook = rst.GetRows End If If IsEmpty(GetDataFromClosedWorkbook) Then rst.MoveFirst ReDim arrTemp(0 To rst.Fields.Count - 1, 0 To rst.RecordCount) i = 0 j = 0 Do Until rst.EOF Err.Clear If i > UBound(arrTemp, 2) Then ReDim Preserve arrTemp(0 To rst.Fields.Count - 1, 0 To i) End If For j = 0 To rst.Fields.Count - 1 arrTemp(j, i) = rst.Fields(j).Value If Err.Number = &HBCD Then Exit For End If Next j i = i + 1     If Err.Number <> &HBCD Then rst.MoveNext End If If Err.Number <> &H80004005 And Err.Number <> 0 Then Exit Do End If Loop GetDataFromClosedWorkbook = arrTemp Erase arrTemp End If ' IsEmpty(GetDataFromClosedWorkbook) End If '  rst.EOF And rst.BOF Then ExitSub: On Error Resume Next rst.Close objConnect.Close ' close the database connection Set rst = Nothing Set objConnect = Nothing Exit Function ErrSub: If InStr(Err.Description, "not a valid name") Then GetDataFromClosedWorkbook = "#ERROR '" & SourceRange & "' does not exist" MsgBox "Cannot read the data from file: " & vbCrLf & vbCrLf & Err.Description & vbCrLf & vbCrLf & "It's possible that the file has been locked, but the most likely explanation is that the file doesn't contain the named sheet or range you're trying to read: check that you've saved the correct C7 report with the correct file name." & vbCrLf & vbCrLf & "If this error persists, please contact the Desktop Support team.", vbCritical, APP_NAME & ": data access error:" ElseIf InStr(Err.Description, "Could not find the object '& SourceRange") Then GetDataFromClosedWorkbook = "#ERROR '" & SourceRange & "' does not exist" MsgBox Err.Description & vbCrLf & vbCrLf & "Please contact the Desktop Support  team. This error probably means that source file is locked, or that the wrong file has been saved here: " & vbCrLf & vbCrLf & strPathFull, vbCritical, APP_NAME & ": file data error:" ElseIf InStr(Err.Description, "Permission Denied") Then GetDataFromClosedWorkbook = "#ERROR Access to file" MsgBox "Cannot open the file: " & vbCrLf & vbCrLf & strPathFull & vbCrLf & vbCrLf & "Another user probably has this file open. Please wait a few minutes, and try again. If this error persists, please contact Desktop Support team.", vbCritical, APP_NAME & ": file access error:" Else GetDataFromClosedWorkbook = "#ERROR " & Err.Number & ": " & Err.Description End If     Resume ExitSub ' # leave in place for debugging: Resume End Function Public Function Filename(ByVal strPath As String) As String strPath = Replace(strPath, "/", "\") If strPath <> "" Then Filename = StrReverse(Split(StrReverse(strPath), "\")(0)) End If End Function Public Function Folder(ByVal strPath As String) As String strPath = Replace(strPath, "/", "\") If strPath <> "" Then    Folder = Left(strPath, Len(strPath) - Len(Filename(strPath))) End If End Function Public Sub SetTypeGuessRows() On Error Resume Next ' necessary because there is no other way of checking the existence of a key 'http://msdn.microsoft.com/en-us/library/yfdfhz1b(v=vs.84).aspx Dim objShell As Object Set objShell = CreateObject("WScript.Shell") Dim strKey As String strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes" If objShell.RegRead(strKey) <> "Text" Then objShell.RegWrite strKey, "Text", "REG_SZ" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes" If objShell.RegRead(strKey) <> "Text" Then objShell.RegWrite strKey, "Text", "REG_SZ" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Excel\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" End If strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Excel\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Excel\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If   strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes" If objShell.RegRead(strKey) <> "Text" Then objShell.RegWrite strKey, "Text", "REG_SZ" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" End If strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If strKey = "HKEY_LOCAL_MACHINE\Software\Microsoft\Jet\4.0\Engines\Text\MaxScanRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\Software\Microsoft\Jet\4.0\Engines\Text\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\Software\Microsoft\Jet\4.0\Engines\Text\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If     strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\ImportMixedTypes" If objShell.RegRead(strKey) <> "Text" Then objShell.RegWrite strKey, "Text", "REG_SZ" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\TypeGuessRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\MaxScanRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Excel\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes" If objShell.RegRead(strKey) <> "Text" Then objShell.RegWrite strKey, "Text", "REG_SZ" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\MaxScanRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Jet\4.0\Engines\Text\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\ImportMixedTypes" If objShell.RegRead(strKey) <> "Text" Then objShell.RegWrite strKey, "Text", "REG_SZ" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\ImportMixedTypes" objShell.RegWrite strKey, "Text", "REG_SZ" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\TypeGuessRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\TypeGuessRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If strKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\MaxScanRows" If objShell.RegRead(strKey) <> 0 Then objShell.RegWrite strKey, 0, "REG_DWORD" End If If objShell.RegRead(strKey) <> 0 Then strKey = "HKEY_CURRENT_USER\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" strKey = "HKEY_CURRENT_CONFIG\SOFTWARE\Wow6432Node\Microsoft\Office\12.0\Access Connectivity Engine\Engines\Text\MaxScanRows" objShell.RegWrite strKey, 0, "REG_DWORD" End If Set objShell = Nothing End Sub




You will also need basArrays, a grab bag of array-handling utilities. I've posted the full set elsewhere, but these are the array functions in use in the code above:

Option Explicit
Option Private Module

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                   (Destination As Any, _
                    Source As Any, _
                    ByVal Length As Long)
                    
                    
Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet
' InputArray must be a 2-Dimensional structure of the form Variant(Rows, Columns)

' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.

' This subroutine saves repetitive coding for a common VBA and Excel task.

' If you think you won't need the code that works around common errors (long strings
' and objects in the array, etc) then feel free to comment them out.

On Error Resume Next

'
' Author: Nigel Heffernan  Http://Excellerando.blogspot.com
'
'
' This code is in the public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on your proprietary code

Dim rngOutput As Excel.Range

Dim iRowCount   As Long
Dim iColCount   As Long
Dim iRow        As Long
Dim iCol        As Long
Dim arrTemp     As Variant
Dim iDimensions As Integer

Dim iRowOffset  As Long
Dim iColOffset  As Long
Dim iStart      As Long


Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
    rngTarget.ClearContents
End If
Application.EnableEvents = True


If IsEmpty(InputArray) Then
    Exit Sub
End If

If TypeName(InputArray) = "Range" Then
    InputArray = InputArray.Value
End If


' Is it actually an array? IsArray is sadly broken so...
If InStr(TypeName(InputArray), "(") < 1 Then
    rngTarget.Cells(1, 1).Value2 = InputArray
    Exit Sub
End If


iDimensions = ArrayDimensions(InputArray)


If iDimensions < 1 Then

    rngTarget.Value = CStr(InputArray)


ElseIf iDimensions = 1 Then

    
    iRowCount = UBound(InputArray) - LBound(InputArray)
    iStart = LBound(InputArray)
    iColCount = 1
    
    If iRowCount > (655354 - rngTarget.Row) Then
        iRowCount = 655354 + iStart - rngTarget.Row
        ReDim Preserve InputArray(iStart To iRowCount)
    End If
    
    iRowCount = UBound(InputArray) - LBound(InputArray)
    iColCount = 1
    
    ' It's a vector. Yes, I asked for a 2-Dimensional array. But I'm feeling generous.
    ' By convention, a vector is presented in Excel as an array of 1 to n rows and 1 column.
    ReDim arrTemp(LBound(InputArray, 1) To UBound(InputArray, 1), 1 To 1)
    For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
        arrTemp(iRow, 1) = InputArray(iRow)
    Next
    
    With rngTarget.Worksheet
        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount))
        rngOutput.Value2 = arrTemp
        Set rngTarget = rngOutput
    End With
    
    Erase arrTemp
    
    

ElseIf iDimensions = 2 Then
    
    
    iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
    iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)
    
    iStart = LBound(InputArray, 1)
    
    If iRowCount > (65534 - rngTarget.Row) Then
        iRowCount = 65534 - rngTarget.Row
        InputArray = ArrayTranspose(InputArray)
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
        InputArray = ArrayTranspose(InputArray)
    End If
    
    
    iStart = LBound(InputArray, 2)
    If iColCount > (254 - rngTarget.Column) Then
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
    End If
    
    
    
    With rngTarget.Worksheet
    
        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))
    
        Err.Clear
        Application.EnableEvents = False
        rngOutput.Value2 = InputArray
        Application.EnableEvents = True
    
        If Err.Number <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Formula = InputArray
        End If 'err<>0
    
        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        If Left(InputArray(iRow, iCol), 1) = "=" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "+" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "*" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Value2 = InputArray
        End If 'err<>0
    
        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
    
                    If IsObject(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
                    ElseIf IsArray(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
                    ElseIf IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        If Len(InputArray(iRow, iCol)) > 255 Then
                            ' Block-write operations fail on strings exceeding 255 chars. You *have*
                            ' to go back and check, and write this masterpiece one cell at a time...
                            InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Text = InputArray
        End If 'err<>0
    
        If Err <> 0 Then
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            iRowOffset = LBound(InputArray, 1) - 1
            iColOffset = LBound(InputArray, 2) - 1
            For iRow = 1 To iRowCount
                If iRow Mod 100 = 0 Then
                    Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
                End If
                For iCol = 1 To iColCount
                    rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
                Next iCol
            Next iRow
            Application.StatusBar = False
            Application.ScreenUpdating = True
    
    
        End If 'err<>0
    
    
        Set rngTarget = rngOutput   ' resizes the range This is useful, *most* of the time
    
    End With  '  rngTarget.Worksheet
    


End If  ' iDimensions



End Sub

Public Function ArrayTranspose(InputArray As Variant) As Variant

Dim arrOutput As Variant

Dim i As Long
Dim j As Long
Dim iMin As Long
Dim iMax As Long
Dim jMin As Long
Dim jMax As Long

iMin = LBound(InputArray, 1)
iMax = UBound(InputArray, 1)
jMin = LBound(InputArray, 2)
jMax = UBound(InputArray, 2)

ReDim arrOutput(jMin To jMax, iMin To iMax)

For i = iMin To iMax
    For j = jMin To jMax
        arrOutput(j, i) = InputArray(i, j)
    Next j
Next i

ArrayTranspose = arrOutput

End Function


Private Function ArrayDimensions(arr As Variant) As Integer
  '-----------------------------------------------------------------
  ' will return:
  ' -1 if not an array
  ' 0  if an un-dimmed array
  ' 1  or more indicating the number of dimensions of a dimmed array
  '-----------------------------------------------------------------


  ' Retrieved from Chris Rae's VBA Code Archive - http://chrisrae.com/vba
  ' Code written by Chris Rae, 25/5/00

  ' Originally published by R. B. Smissaert.
  ' Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax

  Dim ptr As Long
  Dim vType As Integer

  Const VT_BYREF = &H4000&

  'get the real VarType of the argument
  'this is similar to VarType(), but returns also the VT_BYREF bit
  CopyMemory vType, arr, 2

  'exit if not an array
  If (vType And vbArray) = 0 Then
    ArrayDimensions = -1
    Exit Function
  End If

  'get the address of the SAFEARRAY descriptor
  'this is stored in the second half of the
  'Variant parameter that has received the array
  CopyMemory ptr, ByVal VarPtr(arr) + 8, 4

  'see whether the routine was passed a Variant
  'that contains an array, rather than directly an array
  'in the former case ptr already points to the SA structure.
  'Thanks to Monte Hansen for this fix

  If (vType And VT_BYREF) Then
    ' ptr is a pointer to a pointer
    CopyMemory ptr, ByVal ptr, 4
  End If

  'get the address of the SAFEARRAY structure
  'this is stored in the descriptor

  'get the first word of the SAFEARRAY structure
  'which holds the number of dimensions
  '...but first check that saAddr is non-zero, otherwise
  'this routine bombs when the array is uninitialized

  If ptr Then
    CopyMemory ArrayDimensions, ByVal ptr, 2
  End If

End Function


Public Function TableLookup(TableRange As Excel.Range, Optional ColumnLabel As String = "", Optional RowLabel As Variant = "", Optional IndexColumn As Long = 1, Optional Compare As VbCompareMethod = vbTextCompare) As Excel.Range
Application.Volatile False
On Error GoTo ErrSub

' For a contiguous data range having column labels in Row 1, return:
'   The data range, excluding the header row, if no column and row labels are specified;
'   The named data column, excluding the header, if a column label is supplied;
'   The labelled data row, if a row label is supplied;
'   The first data cell matching the column and row label, if both are supplied.
'   The 'index' column containing data row labels is assumed to be 1 (the leftmost column) unless specified by IndexColumn


' If you're calling this repeatedly, consider coding up an indexed
' array with Scripting.Dictionary objects as row & column indices.


Dim rngData As Excel.Range
Dim rngCol  As Excel.Range
Dim rngRow  As Excel.Range
Dim rngCell As Excel.Range

Dim iRow As Long
Dim iCol As Long
Dim iRowCount   As Long
Dim iColCount   As Long


Dim arrColLabel As Variant
Dim arrRowLabel As Variant


iRowCount = TableRange.Rows.Count
iColCount = TableRange.Columns.Count

If iRowCount = 0 Then
    Exit Function
End If


' Check for invalid Index column
If IndexColumn > TableRange.Worksheet.Columns.Count - TableRange.Column Then 'column is off the Right-Hand edge of the sheet
    
    Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "You can't specify column " & IndexColumn & " of your data range, it's off the right-hand edge of the worksheet." & vbCrLf & vbCrLf & "Please check your data range and your index column."

ElseIf IndexColumn + TableRange.Column < 1 Then                              'column is off the Left-Hand edge of the sheet
    
    Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "You can't specify column " & IndexColumn & " of your data range, it's off the left-hand edge worksheet." & vbCrLf & vbCrLf & "Please check your data range and your index column."

End If





Set rngData = TableRange.Worksheet.Range(TableRange.Cells(2, 1), TableRange.Cells(iRowCount, iColCount))


' Orthogonal branches: however we do this, there will be some duplicated code
' This is coded up for readability: feel free to refactor for performance and
' remove any code you consider redundant - but *you* maintain it afterwards

If ColumnLabel = "" And RowLabel = "" Then

    Set TableLookup = rngData
    
ElseIf ColumnLabel <> "" And RowLabel = "" Then  ' return a column of data

    arrColLabel = TableRange.Rows(1).Value2
    For iCol = 1 To iColCount
    
        If VBA.Strings.StrComp(ColumnLabel, arrColLabel(1, iCol), Compare) = 0 Then
            Exit For
        End If
        
    Next iCol
    Erase arrColLabel
    
    If iCol > iColCount Then
        Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & ColumnLabel & "' does not match anything in the header row of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the column label"
    Else
        Set TableLookup = rngData.Columns(iCol)
    End If
    
ElseIf ColumnLabel = "" And RowLabel <> "" Then  ' return a row of data
    
    arrRowLabel = rngData.Cols(IndexColumn).Value2
    For iRow = 1 To iRowCount - 1
    
        If IsNumeric(RowLabel) And IsNumeric(arrRowLabel(iRow, 1)) Then
            'Numeric Comparison
            If CDbl(RowLabel) = CDbl(arrRowLabel(iRow, 1)) Then
                Exit For
            End If
        
        ElseIf IsDate(RowLabel) And IsDate(arrRowLabel(iRow, 1)) Then
            ' Date comparison
            If CVDate(RowLabel) = CVDate(arrRowLabel(iRow, 1)) Then
                Exit For
            End If
        Else
            ' string comparison
            If VBA.Strings.StrComp(RowLabel, arrRowLabel(iRow, 1), Compare) = 0 Then
                Exit For
            End If
        End If
        
    Next iRow
    Erase arrColLabel
    
    If iRow >= iRowCount Then
        Err.Raise -1160664095, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & RowLabel & "' does not match anything in column " & IndexColumn & " of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the row label"
    Else
        Set TableLookup = rngData.Rows(iRow)
    End If
    
    
ElseIf ColumnLabel <> "" And RowLabel <> "" Then  ' return a cell of data

    arrColLabel = TableRange.Rows(1).Value2
    For iCol = 1 To iColCount
    
        If VBA.Strings.StrComp(ColumnLabel, arrColLabel(1, iCol), Compare) = 0 Then
            Exit For
        End If
        
    Next iCol
    Erase arrColLabel
    
    If iCol > iColCount Then
        Err.Raise -1430594559, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & ColumnLabel & "' does not match anything in the header row of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the column label"
    End If
    
        arrRowLabel = rngData.Cols(IndexColumn).Value2
    For iRow = 1 To iRowCount - 1
    
        If IsNumeric(RowLabel) And IsNumeric(arrRowLabel(iRow, 1)) Then
            'Numeric Comparison
            If CDbl(RowLabel) = CDbl(arrRowLabel(iRow, 1)) Then
                Exit For
            End If
        
        ElseIf IsDate(RowLabel) And IsDate(arrRowLabel(iRow, 1)) Then
            ' Date comparison
            If CVDate(RowLabel) = CVDate(arrRowLabel(iRow, 1)) Then
                Exit For
            End If
        Else
            ' string comparison
            If VBA.Strings.StrComp(RowLabel, arrRowLabel(iRow, 1), Compare) = 0 Then
                Exit For
            End If
        End If
        
    Next iRow
    Erase arrColLabel
    
    If iRow >= iRowCount Then
        Err.Raise -1160664095, ThisWorkbook.VBProject.Name & ":" & "TableName()", "The label '" & RowLabel & "' does not match anything in column " & IndexColumn & " of your data table '" & TableRange.Worksheet.Name & "!" & TableRange.Address & "'" & vbCrLf & vbCrLf & "Please check your data range and the row label"
    Else
        Set TableLookup = rngData.Cells(iRow, iCol)
    End If
    
        
End If


ExitSub:
    Exit Function
    
ErrSub:
    
    If Err.HelpContext = 0 Then
        MsgBox "Error 0x" & UCase(Hex(Err.Number)) & ": " & Err.Description, vbExclamation + vbMsgBoxHelpButton, "Error in " & Err.Source
    Else
        MsgBox "Error 0x" & UCase(Hex(Err.Number)) & ": " & Err.Description, vbExclamation + vbMsgBoxHelpButton, "Error in " & Err.Source, Err.HelpFile, Err.HelpContext
    End If
    
    Resume ExitSub
    
    Resume
End Function





No comments:

Post a Comment