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